|
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268 |
- unit utsTextSuite;
-
- {$mode objfpc}{$H+}
-
- interface
-
- uses
- Classes, SysUtils, contnrs, math, syncobjs,
- utsTypes, utsUtils;
-
- type
- TtsImage = class;
- TtsFont = class;
- TtsFontGenerator = class;
- TtsRenderer = class;
- TtsContext = class;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TtsKernel1DItem = packed record
- Offset: Integer;
- Value: Single;
- DataOffset: Integer;
- end;
-
- TtsKernel1D = class
- public
- Size: Integer;
- Items: array of TtsKernel1DItem;
- ItemCount: Integer;
- constructor Create(const aRadius, aStrength: Single);
- end;
-
- TtsImageFunc = procedure(const aImage: TtsImage; X, Y: Integer; var aPixel: TtsColor4f; aArgs: Pointer);
- TtsImage = class(TObject)
- private
- fWidth: Integer;
- fHeight: Integer;
- fFormat: TtsFormat;
-
- fData: Pointer;
- fHasScanlines: Boolean;
- fScanlines: array of Pointer;
-
- function GetScanline(const aIndex: Integer): Pointer;
- function GetIsEmpty: Boolean;
- procedure SetData(const aData: Pointer; const aFormat: TtsFormat = tsFormatEmpty; const aWidth: Integer = 0; const aHeight: Integer = 0);
- procedure UpdateScanlines;
- public
- property IsEmpty: Boolean read GetIsEmpty;
- property Width: Integer read fWidth;
- property Height: Integer read fHeight;
- property Format: TtsFormat read fFormat;
- property Data: Pointer read fData;
- property Scanline[const aIndex: Integer]: Pointer read GetScanline;
-
- function GetPixelAt(const x, y: Integer; out aColor: TtsColor4f): Boolean;
-
- procedure Assign(const aImage: TtsImage);
- procedure CreateEmpty(const aFormat: TtsFormat; const aWidth, aHeight: Integer);
- procedure LoadFromFunc(const aFunc: TtsImageFunc; const aArgs: Pointer);
-
- procedure Resize(const aNewWidth, aNewHeight, X, Y: Integer);
- procedure FindMinMax(out aRect: TtsRect);
-
- procedure FillColor(const aColor: TtsColor4f; const aChannelMask: TtsColorChannels; const aModes: TtsImageModes);
- procedure FillPattern(const aPattern: TtsImage; X, Y: Integer; const aChannelMask: TtsColorChannels; const aModes: TtsImageModes);
- procedure BlendImage(const aImage: TtsImage; const X, Y: Integer);
- procedure Blur(const aHorzKernel, aVertKernel: TtsKernel1D; const aChannelMask: TtsColorChannels);
-
- procedure AddResizingBorder;
-
- constructor Create;
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TtsCharRenderRef = class(TObject);
- TtsChar = class(TObject)
- private
- fCharCode: WideChar;
- fGlyphOrigin: TtsPosition;
- fGlyphRect: TtsRect;
- fAdvance: Integer;
- fRenderRef: TtsCharRenderRef;
- public
- property CharCode: WideChar read fCharCode;
- property GlyphOrigin: TtsPosition read fGlyphOrigin write fGlyphOrigin;
- property GlyphRect: TtsRect read fGlyphRect write fGlyphRect;
- property Advance: Integer read fAdvance write fAdvance;
- property RenderRef: TtsCharRenderRef read fRenderRef write fRenderRef;
-
- constructor Create(const aCharCode: WideChar);
- end;
-
- TtsFontCharArray = packed record
- Chars: array [Byte] of TtsChar;
- CharCount: Byte;
- end;
- PtsFontCharArray = ^TtsFontCharArray;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TtsFont = class(TObject)
- private
- fRenderer: TtsRenderer;
- fGenerator: TtsFontGenerator;
- fProperties: TtsFontProperties;
-
- fCharSpacing: Integer;
- fTabWidth: Integer;
- fLineSpacing: Single;
-
- fChars: array[Byte] of PtsFontCharArray;
- fCreateChars: Boolean;
-
- function HasChar(const aCharCode: WideChar): Boolean;
- function GetChar(const aCharCode: WideChar): TtsChar;
- function GetCharCreate(const aCharCode: WideChar): TtsChar;
- procedure AddChar(const aCharCode: WideChar; const aChar: TtsChar); overload;
- protected
- constructor Create(const aRenderer: TtsRenderer; const aGenerator: TtsFontGenerator; const aProperties: TtsFontProperties);
- public
- property CreateChars: Boolean read fCreateChars write fCreateChars;
- property Char[const aCharCode: WideChar]: TtsChar read GetChar;
-
- property Renderer: TtsRenderer read fRenderer;
- property Generator: TtsFontGenerator read fGenerator;
- property Properties: TtsFontProperties read fProperties;
-
- property CharSpacing: Integer read fCharSpacing write fCharSpacing;
- property TabWidth: Integer read fTabWidth write fTabWidth;
- property LineSpacing: Single read fLineSpacing write fLineSpacing;
-
- function AddChar(const aCharCode: WideChar): TtsChar; overload;
- procedure AddCharRange(const aCharCodeBeg, aCharCodeEnd: WideChar);
- procedure RemoveChar(const aCharCode: WideChar);
- procedure ClearChars;
-
- function GetTextWidthW(aText: PWideChar): Integer;
- function GetTextWidthA(aText: PAnsiChar): Integer;
- procedure GetTextMetric(out aMetric: TtsTextMetric);
-
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TtsPostProcessStepRange = record
- StartChar: WideChar;
- EndChar: WideChar;
- end;
- PtsPostProcessStepRange = ^TtsPostProcessStepRange;
-
- TtsFontProcessStepUsage = (
- tsUsageInclude,
- tsUsageExclude);
-
- TtsPostProcessStep = class(TObject)
- private
- fIncludeCharRange: TList;
- fExcludeCharRange: TList;
-
- procedure ClearList(const aList: TList);
- public
- function IsInRange(const aCharCode: WideChar): Boolean;
- procedure Execute(const aChar: TtsChar; const aCharImage: TtsImage); virtual; abstract;
-
- procedure AddUsageRange(const aUsage: TtsFontProcessStepUsage; const aStartChar, aEndChar: WideChar);
- procedure AddUsageChars(const aUsage: TtsFontProcessStepUsage; aChars: PWideChar);
-
- procedure ClearIncludeRange;
- procedure ClearExcludeRange;
-
- constructor Create;
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TtsFontGenerator = class(TObject)
- private
- fContext: TtsContext;
- fFonts: TObjectList;
- fPostProcessSteps: TObjectList;
-
- function GetPostProcessStepCount: Integer;
- function GetPostProcessStep(const aIndex: Integer): TtsPostProcessStep;
-
- procedure DrawLine(const aChar: TtsChar; const aCharImage: TtsImage; aLinePosition, aLineSize: Integer);
- procedure DoPostProcess(const aChar: TtsChar; const aCharImage: TtsImage);
- protected
- procedure RegisterFont(const aFont: TtsFont);
- procedure UnregisterFont(const aFont: TtsFont);
-
- function GetGlyphMetrics(const aFont: TtsFont; const aCharCode: WideChar; out aGlyphOrigin, aGlyphSize: TtsPosition; out aAdvance: Integer): Boolean; virtual; abstract;
- procedure GetCharImage(const aFont: TtsFont; const aCharCode: WideChar; const aCharImage: TtsImage); virtual; abstract;
- public
- property Context: TtsContext read fContext;
- property PostProcessStepCount: Integer read GetPostProcessStepCount;
- property PostProcessStep[const aIndex: Integer]: TtsPostProcessStep read GetPostProcessStep;
-
- function GenerateChar(const aCharCode: WideChar; const aFont: TtsFont; const aRenderer: TtsRenderer): TtsChar;
-
- function AddPostProcessStep(const aStep: TtsPostProcessStep): TtsPostProcessStep;
- function InsertPostProcessStep(const aIndex: Integer; const aStep: TtsPostProcessStep): TtsPostProcessStep;
- procedure DeletePostProcessStep(const aIndex: Integer);
- procedure ClearPostProcessSteps;
-
- constructor Create(const aContext: TtsContext);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TtsLineItemType = (
- tsItemTypeUnknown,
- tsItemTypeFont,
- tsItemTypeColor,
- tsItemTypeText,
- tsItemTypeSpace,
- tsItemTypeLineBreak,
- tsItemTypeTab,
- tsItemTypeSpacing);
-
- PtsLineItem = ^TtsLineItem;
- TtsLineItem = packed record
- Next: PtsLineItem;
- Prev: PtsLineItem;
- ItemType: TtsLineItemType;
- case TtsLineItemType of
- tsItemTypeFont: (
- Font: TtsFont
- );
- tsItemTypeColor: (
- Color: TtsColor4f;
- );
- tsItemTypeText, tsItemTypeSpace: (
- Text: PWideChar; // text of this item
- TextWidth: Integer; // width of text (in pixel)
- );
- tsItemTypeSpacing: (
- Spacing: Integer;
- );
- end;
-
- TtsLineFlag = (
- tsLastItemIsSpace, // is set if the last item was a space item
- tsMetaValid, // is set if the line meta data is valid
- tsAutoLineBreak // is set if the linebreak was set automatically
- );
- TtsLineFlags = set of TtsLineFlag;
- PtsBlockLine = ^TtsBlockLine;
- TtsBlockLine = packed record
- Next: PtsBlockLine;
- First: PtsLineItem;
- Last: PtsLineItem;
- Flags: TtsLineFlags;
-
- meta: packed record
- Width: Integer; // absolut width of this line
- Height: Integer; // absolute height of this line
- Spacing: Integer; // spacing between lines
- Ascent: Integer; // text ascent
- SpaceCount: Integer; // number of words in this line
- end;
- end;
-
- TtsBlockFlag = (
- tsBlockFlagWordWrap
- );
- TtsBlockFlags = set of TtsBlockFlag;
-
- TtsClipping = (
- tsClipNone, // no clipping
- tsClipWordBorder, // draw all words that have at least one pixel inside the box
- tsClipCharBorder, // draw all chars that have at least one pixel inside the box
- tsClipWordComplete, // draw all words that are completly inside the box
- tsClipCharComplete // draw all chars that are completly inside the box
- );
-
- TtsTextBlock = class(TObject)
- private
- fRenderer: TtsRenderer;
-
- fTop: Integer;
- fLeft: Integer;
- fWidth: Integer;
- fHeight: Integer;
- fFlags: TtsBlockFlags;
- fVertAlign: TtsVertAlignment;
- fHorzAlign: TtsHorzAlignment;
- fClipping: TtsClipping;
-
- fCurrentColor: TtsColor4f;
- fCurrentFont: TtsFont;
- fFirstLine: PtsBlockLine;
- fLastLine: PtsBlockLine;
-
- function GetRect: TtsRect;
-
- function PushLineItem(const aItem: PtsLineItem; const aUpdateLineWidth: Boolean = true): Boolean;
- procedure PushSpacing(const aWidth: Integer);
- procedure FreeLineItem(var aItem: PtsLineItem);
- procedure FreeLineItems(var aItem: PtsLineItem);
-
- procedure FreeLines(var aItem: PtsBlockLine);
-
- function SplitText(aText: PWideChar): PtsLineItem;
- function SplitIntoLines(aItem: PtsLineItem): Boolean;
- procedure TrimSpaces(const aLine: PtsBlockLine);
- procedure UpdateLineMeta(const aLine: PtsBlockLine);
- protected
- property Lines: PtsBlockLine read fFirstLine;
- procedure PushNewLine;
- constructor Create(const aRenderer: TtsRenderer; const aTop, aLeft, aWidth, aHeight: Integer; const aFlags: TtsBlockFlags);
- public
- property Renderer: TtsRenderer read fRenderer;
- property CurrentColor: TtsColor4f read fCurrentColor;
- property CurrentFont: TtsFont read fCurrentFont;
- property Rect: TtsRect read GetRect;
- property Width: Integer read fWidth;
- property Height: Integer read fHeight;
- property Flags: TtsBlockFlags read fFlags;
-
- property Top: Integer read fTop write fTop;
- property Left: Integer read fLeft write fLeft;
- property VertAlign: TtsVertAlignment read fVertAlign write fVertAlign;
- property HorzAlign: TtsHorzAlignment read fHorzAlign write fHorzAlign;
- property Clipping: TtsClipping read fClipping write fClipping;
-
- procedure ChangeFont(const aFont: TtsFont);
- procedure ChangeColor(const aColor: TtsColor4f);
-
- function GetActualBlockHeight: Integer;
-
- procedure TextOutA(const aText: PAnsiChar);
- procedure TextOutW(const aText: PWideChar);
-
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TtsRenderer = class(TObject)
- private
- fContext: TtsContext;
- fFormat: TtsFormat;
- fSaveImages: Boolean;
- fRenderCS: TCriticalSection;
- fBlocks: TObjectList;
-
- procedure RegisterBlock(const aBlock: TtsTextBlock);
- procedure UnregisterBlock(const aBlock: TtsTextBlock);
- protected
- function CreateRenderRef(const aChar: TtsChar; const aCharImage: TtsImage): TtsCharRenderRef; virtual; abstract;
- procedure FreeRenderRef(const aCharRef: TtsCharRenderRef); virtual; abstract;
-
- procedure BeginRender; virtual;
- procedure EndRender; virtual;
-
- procedure SetDrawPos(const X, Y: Integer); virtual; abstract;
- function GetDrawPos: TtsPosition; virtual; abstract;
- procedure MoveDrawPos(const X, Y: Integer); virtual; abstract;
- procedure SetColor(const aColor: TtsColor4f); virtual; abstract;
- procedure Render(const aCharRef: TtsCharRenderRef); virtual; abstract;
- public
- property Context: TtsContext read fContext;
- property Format: TtsFormat read fFormat;
- property SaveImages: Boolean read fSaveImages write fSaveImages;
-
- function BeginBlock(const aTop, aLeft, aWidth, aHeight: Integer; const aFlags: TtsBlockFlags): TtsTextBlock;
- procedure EndBlock(var aBlock: TtsTextBlock);
-
- constructor Create(const aContext: TtsContext; const aFormat: TtsFormat);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TtsContext = class(TObject)
- private
- fCodePage: TtsCodePage;
- fCodePageDefault: WideChar;
-
- fRenderers: TObjectList;
- fGenerators: TObjectList;
- private
- procedure RegisterRenderer(const aRenderer: TtsRenderer);
- procedure UnregisterRenderer(const aRenderer: TtsRenderer);
- procedure RegisterGenerator(const aGenerator: TtsFontGenerator);
- procedure UnregisterGenerator(const aGenerator: TtsFontGenerator);
- public
- property CodePage: TtsCodePage read fCodePage write fCodePage;
- property CodePageDefault: WideChar read fCodePageDefault write fCodePageDefault;
-
- function AnsiToWide(const aText: PAnsiChar): PWideChar;
-
- constructor Create;
- destructor Destroy; override;
- end;
-
- EtsException = class(Exception);
- EtsRenderer = class(EtsException);
- EtsOutOfRange = class(EtsException)
- public
- constructor Create(const aMin, aMax, aIndex: Integer);
- end;
-
- const
- IMAGE_MODES_REPLACE: TtsImageModes = (tsModeReplace, tsModeReplace, tsModeReplace, tsModeReplace);
- IMAGE_MODES_NORMAL: TtsImageModes = (tsModeReplace, tsModeReplace, tsModeReplace, tsModeModulate);
-
- COLOR_CHANNELS_RGB: TtsColorChannels = [tsChannelRed, tsChannelGreen, tsChannelBlue];
- COLOR_CHANNELS_RGBA: TtsColorChannels = [tsChannelRed, tsChannelGreen, tsChannelBlue, tsChannelAlpha];
-
- implementation
-
- const
- IMAGE_MODE_FUNCTIONS: array[TtsImageMode] of TtsImageModeFunc = (
- @tsImageModeFuncIgnore,
- @tsImageModeFuncReplace,
- @tsImageModeFuncModulate);
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TtsKernel1D///////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TtsKernel1D.Create(const aRadius, aStrength: Single);
- var
- TempRadius, SQRRadius, TempStrength, TempValue: Double;
- Idx: Integer;
-
- function CalcValue(const aIndex: Integer): Single;
- var
- Temp: Double;
- begin
- Temp := Max(0, Abs(aIndex) - TempStrength);
- Temp := Sqr(Temp * TempRadius) / SQRRadius;
- result := Exp(-Temp);
- end;
-
- begin
- inherited Create;
-
- // calculate new radius and strength
- TempStrength := Min(aRadius - 1, aRadius * aStrength);
- TempRadius := aRadius - TempStrength;
- SQRRadius := sqr(TempRadius) * sqr(TempRadius);
-
- // caluculating size of the kernel
- Size := Round(TempRadius);
- while CalcValue(Size) > 0.001 do
- Inc(Size);
- Size := Size -1;
- ItemCount := Size * 2 +1;
- SetLength(Items, ItemCount);
-
- // calculate Value (yes thats right. there is no -1)
- for Idx := 0 to Size do begin
- TempValue := CalcValue(Idx);
-
- with Items[Size + Idx] do begin
- Offset := Idx;
- Value := TempValue;
- end;
-
- with Items[Size - Idx] do begin
- Offset := -Idx;
- Value := TempValue;
- end;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TtsImage//////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsImage.GetScanline(const aIndex: Integer): Pointer;
- begin
- if not fHasScanlines then
- UpdateScanlines;
-
- if fHasScanlines and (aIndex >= 0) and (aIndex <= High(fScanlines)) then
- result := fScanlines[aIndex]
- else
- result := nil;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsImage.GetIsEmpty: Boolean;
- begin
- result := not Assigned(fData);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsImage.SetData(const aData: Pointer; const aFormat: TtsFormat; const aWidth: Integer; const aHeight: Integer);
- begin
- fHasScanlines := false;
- if Assigned(fData) then
- FreeMemory(fData);
-
- fData := aData;
- if Assigned(fData) then begin
- fWidth := aWidth;
- fHeight := aHeight;
- fFormat := aFormat;
- end else begin
- fWidth := 0;
- fHeight := 0;
- fFormat := tsFormatEmpty;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsImage.UpdateScanlines;
- var
- i, LineSize: Integer;
- tmp: PByte;
- begin
- LineSize := fWidth * tsFormatSize(fFormat);
- LineSize := LineSize + ((4 - (LineSize mod 4)) mod 4);
- SetLength(fScanlines, fHeight);
- for i := 0 to fHeight-1 do begin
- tmp := fData;
- inc(tmp, i * LineSize);
- fScanlines[i] := tmp;
- end;
- fHasScanlines := true;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsImage.GetPixelAt(const x, y: Integer; out aColor: TtsColor4f): Boolean;
- var
- p: PByte;
- begin
- result := (x >= 0) and (x < Width) and (y >= 0) and (y < Height);
- if result then begin
- p := Scanline[y];
- inc(p, x * tsFormatSize(Format));
- tsFormatUnmap(Format, p, aColor);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsImage.Assign(const aImage: TtsImage);
- var
- ImgData: Pointer;
- ImgSize, LineSize: Integer;
- begin
- LineSize := aImage.Width * tsFormatSize(aImage.Format);
- LineSize := LineSize + ((4 - (LineSize mod 4)) mod 4);
- ImgSize := LineSize * aImage.Height;
- GetMem(ImgData, ImgSize);
- if Assigned(ImgData) then
- Move(aImage.Data, ImgData, ImgSize);
- SetData(ImgData, aImage.Format, aImage.Width, aImage.Height);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsImage.CreateEmpty(const aFormat: TtsFormat; const aWidth, aHeight: Integer);
- var
- ImgData: PByte;
- LineSize: Integer;
- begin
- LineSize := aWidth * tsFormatSize(aFormat);
- LineSize := LineSize + ((4 - (LineSize mod 4)) mod 4);
- ImgData := AllocMem(aHeight * LineSize);
- SetData(ImgData, aFormat, aWidth, aHeight);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsImage.LoadFromFunc(const aFunc: TtsImageFunc; const aArgs: Pointer);
- var
- X, Y: Integer;
- c: TtsColor4f;
- p, tmp: PByte;
- begin
- for Y := 0 to Height - 1 do begin
- p := ScanLine[Y];
- for X := 0 to Width - 1 do begin
- tmp := p;
- tsFormatUnmap(fFormat, tmp, c);
- aFunc(Self, X, Y, c, aArgs);
- tsFormatMap(fFormat, p, c);
- end;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsImage.Resize(const aNewWidth, aNewHeight, X, Y: Integer);
- var
- ImgData: PByte;
- PixSize, LineSize, ImageSize, OrgLineSize: Integer;
-
- src, dst: PByte;
- YStart, YEnd, YPos, XStart, XEnd: Integer;
- begin
- if (aNewHeight = 0) or (aNewWidth = 0) then begin
- SetData(nil);
- exit;
- end;
-
- PixSize := tsFormatSize(Format);
- LineSize := PixSize * aNewWidth;
- ImageSize := LineSize * aNewHeight;
- OrgLineSize := PixSize * Width;
-
- GetMem(ImgData, ImageSize);
- try
- FillChar(ImgData^, ImageSize, 0);
-
- // positions
- YStart := Max(0, Y);
- YEnd := Min(aNewHeight, Y + Height);
- XStart := Max(0, X);
- XEnd := Min(aNewWidth, X + Width);
-
- // copy data
- for YPos := YStart to YEnd -1 do begin
- dst := ImgData;
- Inc(dst, LineSize * YPos + PixSize * XStart);
-
- src := fData;
- Inc(src, OrgLineSize * (YPos - Y) + PixSize * (XStart - X));
-
- Move(src^, dst^, (XEnd - XStart) * PixSize);
- end;
-
- // assign
- SetData(ImgData, Format, aNewWidth, aNewHeight);
- except
- FreeMem(ImgData);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsImage.FindMinMax(out aRect: TtsRect);
- var
- X, Y: Integer;
- c: TtsColor4f;
- p: PByte;
- begin
- aRect.Top := -1;
- aRect.Left := -1;
- aRect.Right := -1;
- aRect.Bottom := -1;
-
- // Search for MinMax
- for Y := 0 to Height-1 do begin
- p := ScanLine[Y];
- for X := 0 to Width-1 do begin
- tsFormatUnmap(Format, p, c);
- if c.a > 0 then begin
- if (X < aRect.Left) or (aRect.Left = -1) then
- aRect.Left := X;
-
- if (X+1 > aRect.Right) or (aRect.Right = -1) then
- aRect.Right := X+1;
-
- if (Y < aRect.Top) or (aRect.Top = -1) then
- aRect.Top := Y;
-
- if (Y+1 > aRect.Bottom) or (aRect.Bottom = -1) then
- aRect.Bottom := Y+1;
- end;
- end;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsImage.FillColor(const aColor: TtsColor4f; const aChannelMask: TtsColorChannels; const aModes: TtsImageModes);
- var
- x, y: Integer;
- p: PByte;
- c: TtsColor4f;
- ch: TtsColorChannel;
- i: Integer;
- begin
- for y := 0 to Height-1 do begin
- p := Scanline[y];
- for x := 0 to Width-1 do begin
- tsFormatUnmap(Format, p, c);
- for i := 0 to 3 do begin
- ch := TtsColorChannel(i);
- if (ch in aChannelMask) then
- c.arr[i] := IMAGE_MODE_FUNCTIONS[aModes[ch]](aColor.arr[i], c.arr[i]);
- end;
- end;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsImage.FillPattern(const aPattern: TtsImage; X, Y: Integer; const aChannelMask: TtsColorChannels; const aModes: TtsImageModes);
- var
- _x, _y, posX, i: Integer;
- src, dst, tmp: PByte;
- cSrc, cDst: TtsColor4f;
- ch: TtsColorChannel;
- begin
- if x < 0 then
- x := Random(aPattern.Width);
- if y < 0 then
- y := Random(aPattern.Height);
-
- for _y := 0 to Height-1 do begin
- src := aPattern.Scanline[(y + _y) mod aPattern.Height];
- dst := Scanline[_y];
-
- inc(src, x);
- posX := x;
-
- for _x := 0 to Width-1 do begin
- if (posX >= aPattern.Width) then begin
- src := aPattern.Scanline[(y + _y) mod aPattern.Height];
- posX := 0;
- end;
-
- tmp := dst;
- tsFormatUnmap(Format, src, cSrc);
- tsFormatUnmap(Format, tmp, cDst);
- for i := 0 to 3 do begin
- ch := TtsColorChannel(i);
- if (ch in aChannelMask) then
- cDst.arr[i] := IMAGE_MODE_FUNCTIONS[aModes[ch]](cSrc.arr[i], cDst.arr[i]);
- end;
- tsFormatMap(Format, dst, cDst);
- inc(posX);
- end;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsImage.BlendImage(const aImage: TtsImage; const X, Y: Integer);
- var
- _x, _y, i: Integer;
- c, cOver, cUnder: TtsColor4f;
- FaqOver, FaqUnder: Single;
- UnionRect, IntersectRect: TtsRect;
- NewSize: TtsPosition;
- ImgSize: Integer;
- ImgData, dst, src, pOver, pUnder: PByte;
- tmpLines: array of Pointer;
- begin
- UnionRect := tsRect(
- Min(X, 0),
- Min(Y, 0),
- Max(X + aImage.Width, Width),
- Max(Y + aImage.Height, Height));
- IntersectRect := tsRect(
- Max(X, 0),
- Max(Y, 0),
- Min(X + aImage.Width, Width),
- Min(X + aImage.Height, Height));
- NewSize := tsPosition(
- UnionRect.Right - UnionRect.Left,
- UnionRect.Bottom - UnionRect.Top);
-
- ImgSize := NewSize.x * NewSize.y * tsFormatSize(Format);
- GetMem(ImgData, ImgSize);
- try
- FillByte(ImgData^, ImgSize, $00);
-
- // temporary scanlines
- SetLength(tmpLines, NewSize.y);
- for _y := 0 to NewSize.y-1 do begin
- tmpLines[_y] := ImgData;
- inc(tmpLines[_y], _y * NewSize.y);
- end;
-
- // copy data from underlaying image
- for _y := 0 to Height-1 do begin
- src := Scanline[_y];
- dst := tmpLines[_y - UnionRect.Top];
- dec(dst, UnionRect.Left);
- for _x := 0 to Width-1 do begin
- dst^ := src^;
- inc(src);
- inc(dst);
- end;
- end;
-
- // copy data from overlaying image
- for _y := 0 to aImage.Height-1 do begin
- src := aImage.Scanline[_y];
- dst := tmpLines[_y + y - UnionRect.Top];
- inc(dst, X - UnionRect.Left);
- for _x := 0 to Width-1 do begin
- dst^ := src^;
- inc(src);
- inc(dst);
- end;
- end;
-
- // blend overlapped
- for _y := IntersectRect.Top to IntersectRect.Bottom-1 do begin
- pOver := aImage.Scanline[_y - Min(IntersectRect.Top, UnionRect.Top)];
- inc(pOver, IntersectRect.Left - UnionRect.Left);
-
- pUnder := Scanline[_y - Min(IntersectRect.Top, 0)];
- inc(pUnder, IntersectRect.Left);
-
- dst := tmpLines[_y - Min(Y, 0)];
- inc(dst, IntersectRect.Left - Min(X, 0));
-
- for _x := IntersectRect.Left to IntersectRect.Right-1 do begin
- tsFormatUnmap(aImage.Format, pOver, cOver);
- tsFormatUnmap(Format, pUnder, cUnder);
- c.a := cOver.a + cUnder.a * (1 - cOver.a);
- if (c.a > 0) then begin
- FaqUnder := (cUnder.a * (1 - cOver.a)) / c.a;
- FaqOver := cOver.a / c.a;
- for i := 0 to 2 do
- c.arr[i] := cOver.arr[i] * FaqOver + cUnder.arr[i] * FaqUnder;
- end else begin
- c.r := 0;
- c.g := 0;
- c.b := 0;
- end;
- tsFormatMap(Format, dst, c);
- end;
- end;
- except
- FreeMem(ImgData);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsImage.Blur(const aHorzKernel, aVertKernel: TtsKernel1D; const aChannelMask: TtsColorChannels);
- var
- tmpImage: TtsImage;
-
- procedure DoBlur(const aSrc, aDst: TtsImage; const aKernel: TtsKernel1D; const ShiftX, ShiftY: Integer);
- var
- x, y, i, j: Integer;
- src, dst: PByte;
- v: Single;
- c, tmp: TtsColor4f;
- begin
- for y := 0 to Height-1 do begin
- src := aSrc.Scanline[y];
- dst := aDst.Scanline[y];
- for x := 0 to Width-1 do begin
-
- // read color and clear channels
- v := 0;
- tsFormatUnmap(aSrc.Format, src, c);
- for j := 0 to 3 do
- if (TtsColorChannel(j) in aChannelMask) then
- c.arr[j] := 0;
-
- // do blur
- for i := 0 to aKernel.ItemCount-1 do with aKernel.Items[i] do begin
- if aSrc.GetPixelAt(x + Offset * ShiftX, y + Offset * ShiftY, tmp) then begin
- for j := 0 to 3 do begin
- if (TtsColorChannel(j) in aChannelMask) then
- c.arr[j] := c.arr[j] + tmp.arr[j] * Value;
- end;
- v := v + Value;
- end;
- end;
-
- // calc final color and write
- for j := 0 to 3 do
- if (TtsColorChannel(i) in aChannelMask) then
- c.arr[j] := c.arr[j] / v;
- tsFormatMap(aDst.Format, dst, c);
- end;
- end;
- end;
-
- begin
- tmpImage := TtsImage.Create;
- try
- tmpImage.CreateEmpty(Format, Width, Height);
- tmpImage.FillColor(tsColor4f(1, 1, 1, 0), COLOR_CHANNELS_RGBA, IMAGE_MODES_REPLACE);
-
- DoBlur(self, tmpImage, aHorzKernel, 1, 0);
- DoBlur(tmpImage, self, aVertKernel, 0, 1);
- finally
- FreeAndNil(tmpImage);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsImage.AddResizingBorder;
- var
- c, cTmp, cSum: TtsColor4f;
- x, y, cnt: Integer;
- p, tmp: PByte;
-
- procedure AddCol(const aColor: TtsColor4f);
- var
- i: Integer;
- begin
- if (aColor.a > 0) then begin
- inc(cnt);
- for i := 0 to 2 do
- cSum.arr[i] := cSum.arr[i] + cTmp.arr[i];
- end;
- end;
-
- var
- i: Integer;
- begin
- Resize(Width + 4, Height + 4, 2, 2);
- for y := 0 to Height-1 do begin
- p := Scanline[y];
- for x := 0 to Width-1 do begin
- FillByte(cSum, SizeOf(cSum), 0);
- cnt := 0;
- tmp := p;
- tsFormatUnmap(Format, tmp, c);
- if (c.a = 0) then begin
-
- // row - 1
- if (y > 0) then begin
-
- // row - 1 | col
- GetPixelAt(x, y-1, cTmp);
- AddCol(cTmp);
-
- //row - 1 | col - 1
- if (x > 0) then begin
- GetPixelAt(x-1, y-1, cTmp);
- AddCol(cTmp);
- end;
-
- // row - 1 | col + 1
- if (x < Width-1) then begin
- GetPixelAt(x+1, y-1, cTmp);
- AddCol(cTmp);
- end;
- end;
-
- // row + 1
- if (y < Height-1) then begin
- // row - 1 | col
- GetPixelAt(x, y+1, cTmp);
- AddCol(cTmp);
-
- //row + 1 | col - 1
- if (x > 0) then begin
- GetPixelAt(x-1, y+1, cTmp);
- AddCol(cTmp);
- end;
-
- // row + 1 | col + 1
- if (x < Width-1) then begin
- GetPixelAt(x+1, y+1, cTmp);
- AddCol(cTmp);
- end;
- end;
-
- //row | col - 1
- if (x > 0) then begin
- GetPixelAt(x-1, y+1, cTmp);
- AddCol(cTmp);
- end;
-
- // row | col + 1
- if (x < Width-1) then begin
- GetPixelAt(x+1, y+1, cTmp);
- AddCol(cTmp);
- end;
-
- // any pixel next to the transparent pixel they are opaque?
- if (cnt > 0) then begin
- for i := 0 to 2 do
- c.arr[i] := cSum.arr[i] / cnt;
- end;
- end;
- tsFormatMap(Format, p, c);
- end;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TtsImage.Create;
- begin
- inherited Create;
- SetData(nil);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TtsImage.Destroy;
- begin
- SetData(nil);
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TtsChar///////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TtsChar.Create(const aCharCode: WideChar);
- begin
- inherited Create;
- fCharCode := aCharCode;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TtsFont///////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsFont.HasChar(const aCharCode: WideChar): Boolean;
- begin
- result := Assigned(GetChar(aCharCode));
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsFont.GetChar(const aCharCode: WideChar): TtsChar;
- var
- Chars: PtsFontCharArray;
- begin
- if (Ord(aCharCode) > 0) then begin
- Chars := fChars[(Ord(aCharCode) shr 8) and $FF];
- if Assigned(Chars) then
- result := Chars^.Chars[Ord(aCharCode) and $FF]
- else
- result := nil;
- end else
- result := nil;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsFont.GetCharCreate(const aCharCode: WideChar): TtsChar;
- begin
- result := GetChar(aCharCode);
- if not Assigned(result) then
- result := AddChar(aCharCode);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsFont.AddChar(const aCharCode: WideChar; const aChar: TtsChar);
- var
- h, l: Integer;
- Chars: PtsFontCharArray;
- begin
- h := (Ord(aCharCode) shr 8) and $FF;
- Chars := fChars[h];
- if not Assigned(Chars) then begin
- New(Chars);
- FillChar(Chars^, SizeOf(Chars^), 0);
- fChars[h] := Chars;
- end;
-
- if Assigned(Chars) then begin
- l := Ord(aCharCode) and $FF;
- Chars^.Chars[l] := aChar;
- inc(Chars^.CharCount);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TtsFont.Create(const aRenderer: TtsRenderer; const aGenerator: TtsFontGenerator; const aProperties: TtsFontProperties);
- begin
- inherited Create;
- fRenderer := aRenderer;
- fGenerator := aGenerator;
- fProperties := aProperties;
- fCharSpacing := 0;
- fTabWidth := 0;
- fLineSpacing := 0.0;
- fCreateChars := true;
- fGenerator.RegisterFont(self);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsFont.AddChar(const aCharCode: WideChar): TtsChar;
- begin
- result := GetChar(aCharCode);
- if not Assigned(result) and fCreateChars and (Ord(aCharCode) > 0) then begin
- result := fGenerator.GenerateChar(aCharCode, self, fRenderer);
- if Assigned(result) then
- AddChar(aCharCode, result);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsFont.AddCharRange(const aCharCodeBeg, aCharCodeEnd: WideChar);
- var
- c: WideChar;
- begin
- for c := aCharCodeBeg to aCharCodeEnd do
- AddChar(c);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsFont.RemoveChar(const aCharCode: WideChar);
- var
- h, l: Integer;
- Chars: PtsFontCharArray;
- c: TtsChar;
- begin
- // find char array
- h := (Ord(aCharCode) shr 8) and $FF;
- Chars := fChars[h];
- if not Assigned(Chars) then
- exit;
-
- // find char
- l := Ord(aCharCode) and $FF;
- c := Chars^.Chars[l];
- if not Assigned(c) then
- exit;
-
- // remove char
- Chars^.Chars[l] := nil;
- dec(Chars^.CharCount);
- if (Chars^.CharCount <= 0) then begin
- fChars[h] := nil;
- Dispose(Chars);
- end;
-
- if Assigned(c.RenderRef) then begin
- fRenderer.FreeRenderRef(c.RenderRef);
- c.RenderRef := nil;
- end;
- FreeAndNil(c);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsFont.ClearChars;
- var
- h, l: Integer;
- Chars: PtsFontCharArray;
- c: TtsChar;
- begin
- for h := Low(fChars) to High(fChars) do begin
- Chars := fChars[h];
- if Assigned(Chars) then begin
- for l := Low(Chars^.Chars) to High(Chars^.Chars) do begin
- c := Chars^.Chars[l];
- if Assigned(c) then begin
- if Assigned(c.RenderRef) then
- fRenderer.FreeRenderRef(c.RenderRef);
- FreeAndNil(c);
- end;
- end;
- Dispose(Chars);
- fChars[h] := nil;
- end;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsFont.GetTextWidthW(aText: PWideChar): Integer;
- var
- c: TtsChar;
- begin
- result := 0;
- if not Assigned(aText) then
- exit;
-
- while (aText^ <> #0) do begin
- c := AddChar(aText^);
- if not Assigned(c) then
- c := AddChar(fProperties.DefaultChar);
- if Assigned(c) then begin
- if (result > 0) then
- result := result + CharSpacing;
- result := result + c.Advance;
- end;
- inc(aText);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsFont.GetTextWidthA(aText: PAnsiChar): Integer;
- var
- tmp: PWideChar;
- begin
- tmp := fGenerator.Context.AnsiToWide(aText);
- try
- result := GetTextWidthW(tmp);
- finally
- tsStrDispose(tmp);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsFont.GetTextMetric(out aMetric: TtsTextMetric);
- begin
- aMetric.Ascent := fProperties.Ascent;
- aMetric.Descent := fProperties.Descent;
- aMetric.ExternalLeading := fProperties.ExternalLeading;
- aMetric.BaseLineOffset := fProperties.BaseLineOffset;
- aMetric.CharSpacing := CharSpacing;
- aMetric.LineHeight := fProperties.Ascent + fProperties.Descent + fProperties.ExternalLeading;
- aMetric.LineSpacing := Trunc(fProperties.Size * fLineSpacing);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TtsFont.Destroy;
- begin
- fGenerator.UnregisterFont(self);
- ClearChars;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TtsPostProcessStep////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsPostProcessStep.ClearList(const aList: TList);
- var
- i: Integer;
- p: PtsPostProcessStepRange;
- begin
- for i := 0 to aList.Count-1 do begin
- p := aList[i];
- Dispose(p);
- end;
- aList.Clear;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsPostProcessStep.IsInRange(const aCharCode: WideChar): Boolean;
- var
- i: Integer;
- p: PtsPostProcessStepRange;
- begin
- result := (fIncludeCharRange.Count = 0);
-
- if not result then for i := 0 to fIncludeCharRange.Count-1 do begin
- p := fIncludeCharRange[i];
- if (aCharCode >= p^.StartChar) and (aCharCode <= p^.EndChar) then begin
- result := true;
- break;
- end;
- end;
-
- if result then for i := 0 to fExcludeCharRange.Count-1 do begin
- p := fExcludeCharRange[i];
- if (aCharCode >= p^.StartChar) and (aCharCode <= p^.EndChar) then begin
- result := false;
- break;
- end;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsPostProcessStep.AddUsageRange(const aUsage: TtsFontProcessStepUsage; const aStartChar, aEndChar: WideChar);
- var
- p: PtsPostProcessStepRange;
- begin
- New(p);
-
- p^.StartChar := aStartChar;
- p^.EndChar := aEndChar;
-
- case aUsage of
- tsUsageInclude:
- fIncludeCharRange.Add(p);
- tsUsageExclude:
- fExcludeCharRange.Add(p);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsPostProcessStep.AddUsageChars(const aUsage: TtsFontProcessStepUsage; aChars: PWideChar);
- begin
- if Assigned(aChars) then
- while (aChars^ <> #0) do begin
- AddUsageRange(aUsage, aChars^, aChars^);
- inc(aChars);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsPostProcessStep.ClearIncludeRange;
- begin
- ClearList(fIncludeCharRange);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsPostProcessStep.ClearExcludeRange;
- begin
- ClearList(fExcludeCharRange);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TtsPostProcessStep.Create;
- begin
- inherited Create;
- fIncludeCharRange := TList.Create;
- fExcludeCharRange := TList.Create;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TtsPostProcessStep.Destroy;
- begin
- ClearList(fIncludeCharRange);
- ClearList(fExcludeCharRange);
- FreeAndNil(fIncludeCharRange);
- FreeAndNil(fExcludeCharRange);
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TtsFontGenerator//////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsFontGenerator.GetPostProcessStepCount: Integer;
- begin
- result := fPostProcessSteps.Count;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsFontGenerator.GetPostProcessStep(const aIndex: Integer): TtsPostProcessStep;
- begin
- if (aIndex >= 0) and (aIndex < fPostProcessSteps.Count) then
- Result := TtsPostProcessStep(fPostProcessSteps[aIndex])
- else
- raise EtsOutOfRange.Create(0, fPostProcessSteps.Count-1, aIndex);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsFontGenerator.DrawLine(const aChar: TtsChar; const aCharImage: TtsImage; aLinePosition, aLineSize: Integer);
- var
- NewSize, NewPos: TtsPosition;
- YOffset, y: Integer;
-
- procedure FillLine(aData: PByte);
- var
- w, i: Integer;
- c: TtsColor4f;
- tmp: PByte;
- begin
- w := NewSize.x;
- while (w > 0) do begin
- tmp := aData;
- tsFormatUnmap(aCharImage.Format, tmp, c);
- for i := 0 to 3 do
- c.arr[i] := 1.0;
- tsFormatMap(aCharImage.Format, aData, c);
- dec(w);
- end;
- end;
-
- begin
- if aLineSize <= 0 then
- exit;
-
- aLinePosition := aLinePosition - aLineSize;
-
- // calculate width and height
- NewPos.x := 0;
- NewPos.y := 0;
- NewSize.x := aCharImage.Width;
- NewSize.y := aCharImage.Height;
-
- // expand image to the full advance
- if aChar.Advance > aCharImage.Width then
- NewSize.x := aChar.Advance;
-
- // add glyph position to image width and set position
- if aChar.GlyphOrigin.x > aChar.GlyphRect.Left then begin
- NewSize.x := NewSize.x + aChar.GlyphOrigin.x;
- NewPos.x := aChar.GlyphOrigin.x;
- end;
- if (aChar.GlyphOrigin.x < 0) then
- NewSize.x := NewSize.x - aChar.GlyphOrigin.x;
-
- // line is under the image
- if aLinePosition < (aChar.GlyphOrigin.y - aCharImage.Height) then
- NewSize.y := NewSize.y + (aChar.GlyphOrigin.y - aCharImage.Height - aLinePosition);
-
- // line is above the image
- if aLinePosition + aLineSize > aChar.GlyphOrigin.y then begin
- NewPos.y := ((aLinePosition + aLineSize) - aChar.GlyphOrigin.y);
- NewSize.y := NewSize.y + NewPos.y;
- end;
-
- // resize
- aCharImage.Resize(NewSize.x, NewSize.y, NewPos.x, NewPos.y);
-
- // draw lines
- YOffset := (aChar.GlyphOrigin.y + NewPos.y) - aLinePosition;
- for y := 1 to aLineSize do
- FillLine(aCharImage.ScanLine[YOffset - y]);
-
- // move glyph rect
- aChar.GlyphRect := tsRect(
- aChar.GlyphRect.Left + NewPos.x,
- aChar.GlyphRect.Right + NewPos.x,
- aChar.GlyphRect.Top + NewPos.y,
- aChar.GlyphRect.Bottom + NewPos.y);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsFontGenerator.DoPostProcess(const aChar: TtsChar; const aCharImage: TtsImage);
- var
- i: Integer;
- step: TtsPostProcessStep;
- begin
- if not aCharImage.IsEmpty then begin
- for i := 0 to fPostProcessSteps.Count-1 do begin
- step := TtsPostProcessStep(fPostProcessSteps[i]);
- if step.IsInRange(aChar.CharCode) then
- step.Execute(aChar, aCharImage);
- end;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsFontGenerator.RegisterFont(const aFont: TtsFont);
- begin
- fFonts.Add(aFont);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsFontGenerator.UnregisterFont(const aFont: TtsFont);
- begin
- if Assigned(fFonts) then
- fFonts.Remove(aFont);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsFontGenerator.GenerateChar(const aCharCode: WideChar; const aFont: TtsFont; const aRenderer: TtsRenderer): TtsChar;
- var
- GlyphOrigin, GlyphSize: TtsPosition;
- Advance: Integer;
- CharImage: TtsImage;
- begin
- result := nil;
- if (Ord(aCharCode) = 0) or
- not GetGlyphMetrics(aFont, aCharCode, GlyphOrigin, GlyphSize, Advance) or
- not ((GlyphOrigin.x <> 0) or (GlyphOrigin.y <> 0) or (GlyphSize.x <> 0) or (GlyphSize.y <> 0) or (Advance <> 0)) then
- exit;
-
- CharImage := TtsImage.Create;
- try
- if aRenderer.SaveImages then begin
- if (GlyphSize.x > 0) and (GlyphSize.y > 0) then begin
- GetCharImage(aFont, aCharCode, CharImage);
- end else if ([tsStyleUnderline, tsStyleStrikeout] * aFont.Properties.Style <> []) then begin
- CharImage.CreateEmpty(aRenderer.Format, Advance, 1);
- GlyphOrigin.y := 1;
- end;
- end;
-
- result := TtsChar.Create(aCharCode);
- try
- result.GlyphOrigin := GlyphOrigin;
- result.GlyphRect := tsRect(0, 0, CharImage.Width, CharImage.Height);
- result.Advance := Advance;
-
- if (aRenderer.SaveImages) then begin
- try
- if (tsStyleUnderline in aFont.Properties.Style) then
- DrawLine(result, CharImage, aFont.Properties.UnderlinePos, aFont.Properties.UnderlineSize);
- if (tsStyleUnderline in aFont.Properties.Style) then
- DrawLine(result, CharImage, aFont.Properties.StrikeoutPos, aFont.Properties.StrikeoutSize);
- except
- CharImage.FillColor(tsColor4f(1, 0, 0, 0), COLOR_CHANNELS_RGB, IMAGE_MODES_NORMAL);
- end;
-
- DoPostProcess(result, CharImage);
-
- result.RenderRef := aRenderer.CreateRenderRef(result, CharImage);
- end;
- except
- FreeAndNil(result);
- end;
- finally
- FreeAndNil(CharImage);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsFontGenerator.AddPostProcessStep(const aStep: TtsPostProcessStep): TtsPostProcessStep;
- begin
- result := aStep;
- fPostProcessSteps.Add(aStep);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsFontGenerator.InsertPostProcessStep(const aIndex: Integer; const aStep: TtsPostProcessStep): TtsPostProcessStep;
- begin
- result := aStep;
- fPostProcessSteps.Insert(aIndex, aStep);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsFontGenerator.DeletePostProcessStep(const aIndex: Integer);
- begin
- if (aIndex >= 0) and (aIndex < fPostProcessSteps.Count) then
- fPostProcessSteps.Delete(aIndex)
- else
- raise EtsOutOfRange.Create(0, fPostProcessSteps.Count-1, aIndex);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsFontGenerator.ClearPostProcessSteps;
- begin
- fPostProcessSteps.Clear;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TtsFontGenerator.Create(const aContext: TtsContext);
- begin
- inherited Create;
- fContext := aContext;
- fFonts := TObjectList.Create(false);
- fPostProcessSteps := TObjectList.Create(true);
- fContext.RegisterGenerator(self);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TtsFontGenerator.Destroy;
- begin
- ClearPostProcessSteps;
- fContext.UnregisterGenerator(self);
- fFonts.OwnsObjects := true;
- FreeAndNil(fFonts);
- FreeAndNil(fPostProcessSteps);
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TtsTextBlock//////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsTextBlock.GetRect: TtsRect;
- begin
- result.Left := fLeft;
- result.Top := fTop;
- result.Right := fLeft + fWidth;
- result.Bottom := fTop + fHeight;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsTextBlock.PushLineItem(const aItem: PtsLineItem; const aUpdateLineWidth: Boolean): Boolean;
- begin
- result := false;
- if not Assigned(fLastLine) then
- PushNewLine;
-
- if not Assigned(fLastLine^.First) and
- (aItem^.ItemType in [tsItemTypeSpace, tsItemTypeSpacing]) then
- exit; // di not add line space or line spacing if line is empty
-
- if Assigned(fLastLine^.Last) then begin
- aItem^.Prev := fLastLine^.Last;
- aItem^.Next := nil;
- fLastLine^.Last^.Next := aItem;
- fLastLine^.Last := aItem;
- end;
-
- if not Assigned(fLastLine^.First) then begin
- fLastLine^.First := aItem;
- fLastLine^.Last := aItem;
- end;
-
- case aItem^.ItemType of
- tsItemTypeSpace, tsItemTypeText:
- fLastLine^.meta.Width := fLastLine^.meta.Width + aItem^.TextWidth;
- tsItemTypeSpacing:
- fLastLine^.meta.Width := fLastLine^.meta.Width + aItem^.Spacing;
- end;
- result := true;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsTextBlock.PushSpacing(const aWidth: Integer);
- var
- p: PtsLineItem;
- begin
- if (aWidth <= 0) then
- exit;
- new(p);
- FillByte(p^, SizeOf(p^), 0);
- p^.ItemType := tsItemTypeSpacing;
- p^.Spacing := aWidth;
- PushLineItem(p);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsTextBlock.FreeLineItem(var aItem: PtsLineItem);
- begin
- if Assigned(aItem^.Prev) then
- aItem^.Prev^.Next := aItem^.Next;
- if Assigned(aItem^.Next) then
- aItem^.Next^.Prev := aItem^.Prev;
- case aItem^.ItemType of
- tsItemTypeText, tsItemTypeSpace:
- tsStrDispose(aItem^.Text);
- end;
- Dispose(aItem);
- aItem := nil;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsTextBlock.FreeLineItems(var aItem: PtsLineItem);
- var
- p: PtsLineItem;
- begin
- while Assigned(aItem) do begin
- p := aItem;
- aItem := aItem^.Next;
- FreeLineItem(p);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsTextBlock.FreeLines(var aItem: PtsBlockLine);
- var
- p: PtsBlockLine;
- begin
- while Assigned(aItem) do begin
- p := aItem;
- aItem := aItem^.Next;
- FreeLineItems(p^.First);
- p^.Last := nil;
- Dispose(p);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsTextBlock.SplitText(aText: PWideChar): PtsLineItem;
- var
- TextBegin: PWideChar;
- TextLength: Integer;
- State: TtsLineItemType;
- LastItem: PtsLineItem;
-
- procedure AddItem(const aItem: PtsLineItem);
- begin
- if Assigned(result) then begin
- LastItem^.Next := aItem;
- aItem^.Prev := LastItem;
- aItem^.Next := nil;
- LastItem := aItem;
- end;
-
- if not Assigned(result) then begin
- result := aItem;
- LastItem := aItem;
- end;
- end;
-
- procedure ExtractWord;
- var
- p: PtsLineItem;
- Text: PWideChar;
- begin
- if (State = tsItemTypeUnknown) then
- exit;
-
- new(p);
- FillByte(p^, SizeOf(p^), 0);
- p^.ItemType := State;
-
- case State of
- tsItemTypeText, tsItemTypeSpace: begin
- p^.Text := tsStrAlloc(TextLength);
- TextLength := 0;
- Text := p^.Text;
- while (TextBegin <> aText) do begin
- Text^ := TextBegin^;
- inc(Text, 1);
- inc(TextBegin, 1);
- end;
- AddItem(p);
- end;
-
- tsItemTypeLineBreak: begin
- AddItem(p);
- TextBegin := aText;
- end;
-
- tsItemTypeTab: begin
- AddItem(p);
- end;
-
- else
- Dispose(p);
- p := nil;
- end;
- end;
-
- begin
- result := nil;
- LastItem := nil;
- TextBegin := aText;
- TextLength := 0;
- State := tsItemTypeUnknown;
-
- if not Assigned(aText) then
- exit;
-
- while (aText^ <> #0) do begin
- case aText^ of
-
- // line breaks
- #$000D, #$000A: begin
- if (State <> tsItemTypeLineBreak) then begin
- ExtractWord;
- State := tsItemTypeLineBreak;
- end else if (TextBegin^ <> #13) or (aText^ <> #10) or (TextBegin + 1 < aText) then
- ExtractWord;
- end;
-
- // spaces
- #$0020: begin
- if (State <> tsItemTypeSpace) then
- ExtractWord;
- State := tsItemTypeSpace;
- end;
-
- // tabulator
- #$0009: begin
- if (State <> tsItemTypeTab) then
- ExtractWord;
- State := tsItemTypeTab;
- end;
-
- else
- if (State <> tsItemTypeText) then
- ExtractWord;
- State := tsItemTypeText;
- end;
-
- inc(aText, 1);
- inc(TextLength, 1);
- end;
-
- if (TextBegin <> aText) then
- ExtractWord;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsTextBlock.SplitIntoLines(aItem: PtsLineItem): Boolean;
- var
- p: PtsLineItem;
- begin
- result := false;
- if not Assigned(fCurrentFont) then
- exit;
-
- result := true;
- while Assigned(aItem) do begin
- p := aItem;
- aItem := aItem^.Next;
- p^.Next := nil;
- p^.Prev := nil;
-
- if not Assigned(fLastLine) then
- PushNewLine;
-
- case p^.ItemType of
- tsItemTypeText, tsItemTypeSpace: begin
- // increment word counter
- if (p^.ItemType = tsItemTypeSpace) then begin
- if not (tsLastItemIsSpace in fLastLine^.Flags) then
- inc(fLastLine^.meta.SpaceCount, 1);
- Include(fLastLine^.Flags, tsLastItemIsSpace);
- end else
- Exclude(fLastLine^.Flags, tsLastItemIsSpace);
-
- // update and check line width
- p^.TextWidth := fCurrentFont.GetTextWidthW(p^.Text);
- if (tsBlockFlagWordWrap in fFlags) and
- (fLastLine^.meta.Width + p^.TextWidth > fWidth) then
- begin
- if (fLastLine^.meta.Width = 0) then begin
- if not PushLineItem(p, false) then // if is first word, than add anyway
- FreeLineItem(p);
- p := nil;
- end;
- include(fLastLine^.Flags, tsAutoLineBreak);
- PushNewLine;
- end;
-
- // add item
- if Assigned(p) then begin
- if not PushLineItem(p) then
- FreeLineItem(p);
- PushSpacing(fCurrentFont.CharSpacing);
- end;
- end;
-
- tsItemTypeLineBreak: begin
- if not PushLineItem(p) then
- FreeLineItem(p);
- PushNewLine;
- end;
-
- tsItemTypeTab: begin
- if not PushLineItem(p) then
- FreeLineItem(p);
- end;
-
- else
- raise EtsException.Create('unexpected line item');
- end;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsTextBlock.TrimSpaces(const aLine: PtsBlockLine);
-
- procedure Trim(var aItem: PtsLineItem; const aMoveNext: Boolean);
- var
- tmp, p: PtsLineItem;
- IsFirst: Boolean;
- begin
- IsFirst := true;
- p := aItem;
- while Assigned(p) do begin
- tmp := p;
- if aMoveNext then
- p := p^.Next
- else
- p := p^.Prev;
-
- case tmp^.ItemType of
- tsItemTypeText: begin //done
- break;
- end;
-
- tsItemTypeSpace,
- tsItemTypeSpacing: begin
- // update line meta
- if (tmp^.ItemType = tsItemTypeSpace) then begin
- aLine^.meta.Width := aLine^.meta.Width - tmp^.TextWidth;
- dec(aLine^.meta.SpaceCount, 1);
- end else
- aLine^.meta.Width := aLine^.meta.Width - tmp^.Spacing;
-
- FreeLineItem(tmp);
- if IsFirst then
- aItem := p;
- end;
-
- else
- IsFirst := false;
- end;
- end;
- end;
-
- begin
- if not Assigned(aLine) then
- exit;
- Trim(aLine^.First, true);
- Trim(aLine^.Last, false);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsTextBlock.UpdateLineMeta(const aLine: PtsBlockLine);
- var
- metric: TtsTextMetric;
- begin
- if not Assigned(fCurrentFont) or
- not Assigned(aLine) then
- exit;
-
- fCurrentFont.GetTextMetric(metric);
- if (tsMetaValid in aLine^.Flags) then begin
- aLine^.meta.Height := max(
- aLine^.meta.Height,
- metric.LineHeight);
- aLine^.meta.Spacing := max(
- aLine^.meta.Spacing,
- metric.LineSpacing);
- aLine^.meta.Ascent := max(
- aLine^.meta.Ascent,
- metric.Ascent);
- end else begin
- Include(aLine^.Flags, tsMetaValid);
- aLine^.meta.Height := metric.LineHeight;
- aLine^.meta.Spacing := metric.LineSpacing;
- aLine^.meta.Ascent := metric.Ascent;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsTextBlock.PushNewLine;
- var
- p: PtsBlockLine;
- begin
- TrimSpaces(fLastLine);
-
- new(p);
- FillByte(p^, SizeOf(p^), 0);
- UpdateLineMeta(p);
-
- if Assigned(fLastLine) then begin
- fLastLine^.Next := p;
- fLastLine := p;
- end;
-
- if not Assigned(fFirstLine) then begin
- fFirstLine := p;
- fLastLine := p;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TtsTextBlock.Create(const aRenderer: TtsRenderer; const aTop, aLeft, aWidth, aHeight: Integer; const aFlags: TtsBlockFlags);
- begin
- inherited Create;
-
- fRenderer := aRenderer;
- fTop := aTop;
- fLeft := aLeft;
- fWidth := aWidth;
- fHeight := aHeight;
- fFlags := aFlags;
- fVertAlign := tsVertAlignTop;
- fHorzAlign := tsHorzAlignLeft;
-
- fRenderer.RegisterBlock(self);
- PushNewLine;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsTextBlock.ChangeFont(const aFont: TtsFont);
- var
- p: PtsLineItem;
- begin
- if not Assigned(aFont) then
- exit;
-
- New(p);
- FillByte(p^, SizeOf(p^), 0);
- fCurrentFont := aFont;
- p^.ItemType := tsItemTypeFont;
- p^.Font := fCurrentFont;
- PushLineItem(p);
- UpdateLineMeta(fLastLine);
- fRenderer.UnregisterBlock(self);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsTextBlock.ChangeColor(const aColor: TtsColor4f);
- var
- p: PtsLineItem;
- begin
- New(p);
- FillByte(p^, SizeOf(p^), 0);
- p^.ItemType := tsItemTypeColor;
- p^.Color := aColor;
- PushLineItem(p);
-
- fCurrentColor := aColor;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsTextBlock.GetActualBlockHeight: Integer;
- var
- line: PtsBlockLine;
- begin
- result := 0;
- line := fFirstLine;
- while Assigned(line) do begin
- result := result + line^.meta.Height;
- line := line^.Next;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsTextBlock.TextOutA(const aText: PAnsiChar);
- var
- tmp: PWideChar;
- begin
- tmp := Renderer.Context.AnsiToWide(aText);
- try
- TextOutW(tmp);
- finally
- tsStrDispose(tmp);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsTextBlock.TextOutW(const aText: PWideChar);
- var
- p: PtsLineItem;
- begin
- p := SplitText(aText);
- if not SplitIntoLines(p) then
- FreeLineItems(p);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TtsTextBlock.Destroy;
- begin
- FreeLines(fFirstLine);
- fLastLine := nil;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TtsRenderer///////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsRenderer.RegisterBlock(const aBlock: TtsTextBlock);
- begin
- fBlocks.Add(aBlock);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsRenderer.UnregisterBlock(const aBlock: TtsTextBlock);
- begin
- if Assigned(fBlocks) then
- fBlocks.Remove(aBlock);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsRenderer.BeginRender;
- begin
- fRenderCS.Enter;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsRenderer.EndRender;
- begin
- fRenderCS.Leave;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsRenderer.BeginBlock(const aTop, aLeft, aWidth, aHeight: Integer; const aFlags: TtsBlockFlags): TtsTextBlock;
- begin
- result := TtsTextBlock.Create(self, aTop, aLeft, aWidth, aHeight, aFlags);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsRenderer.EndBlock(var aBlock: TtsTextBlock);
- var
- c: PWideChar;
- pos: TtsPosition;
- x, y, tmp, tab: Integer;
- ExtraSpaceTotal, ExtraSpaceActual: Single;
- rect: TtsRect;
- line: PtsBlockLine;
- item: PtsLineItem;
- font: TtsFont;
- char: TtsChar;
- metric: TtsTextMetric;
- DrawText: Boolean;
-
- function GetChar(const aCharCode: WideChar): TtsChar;
- begin
- result := font.AddChar(aCharCode);
- if not Assigned(result) then
- result := font.AddChar(font.Properties.DefaultChar);
- end;
-
- procedure DrawItem;
- begin
- case item^.ItemType of
- tsItemTypeFont: begin
- font := item^.Font;
- font.GetTextMetric(metric);
- end;
-
- tsItemTypeColor: begin
- SetColor(item^.Color);
- end;
-
- tsItemTypeText: begin
- if DrawText and Assigned(font) then begin
- c := item^.Text;
- while (c^ <> #0) do begin
- char := GetChar(c^);
- if Assigned(char) then begin
- MoveDrawPos(Char.GlyphOrigin.x, -metric.BaseLineOffset);
- Render(char.RenderRef);
- MoveDrawPos(char.Advance - char.GlyphOrigin.x + font.CharSpacing, metric.BaseLineOffset);
- end;
- inc(c);
- end;
- end;
- end;
-
- tsItemTypeSpace: begin
- if DrawText and Assigned(font) then begin
- ExtraSpaceActual := ExtraSpaceActual + ExtraSpaceTotal;
- c := item^.Text;
- while (c^ <> #0) do begin
- char := GetChar(c^);
- if Assigned(char) then begin
- if (font.Properties.Style * [tsStyleUnderline, tsStyleStrikeout] <> []) then begin
- MoveDrawPos(char.GlyphOrigin.x, -metric.BaseLineOffset);
- Render(char.RenderRef);
- MoveDrawPos(char.Advance - char.GlyphOrigin.x + font.CharSpacing, metric.BaseLineOffset);
- end else begin
- MoveDrawPos(char.Advance + font.CharSpacing, 0);
- end;
- end;
- inc(c);
- end;
-
- tmp := Trunc(ExtraSpaceActual);
- ExtraSpaceActual := ExtraSpaceActual - tmp;
- if (font.Properties.Style * [tsStyleUnderline, tsStyleStrikeout] <> []) then begin
- // TODO draw lines; maybe with a temporary created fake char or something like an empty char?
- end;
- MoveDrawPos(tmp, 0);
- end;
- end;
-
- tsItemTypeLineBreak: begin
- // because this should be the last item in a line, we have nothing to do here
- end;
-
- tsItemTypeTab: begin
- // get current x pos and round it to TabWidth
- pos := GetDrawPos;
- tab := font.TabWidth * font.Properties.Size;
- pos.x := Ceil(pos.x * tab) div tab;
- SetDrawPos(pos.x, pos.y);
- end;
-
- tsItemTypeSpacing: begin
- MoveDrawPos(item^.Spacing, 0);
- end;
- end;
- end;
-
- procedure DrawLine;
- begin
- // check vertical clipping
- case aBlock.Clipping of
- tsClipCharBorder, tsClipWordBorder:
- DrawText := (y + line^.meta.Height > rect.Top) and (y < rect.Bottom);
- tsClipCharComplete, tsClipWordComplete:
- DrawText := (y > rect.Top) and (y + line^.meta.Height < rect.Bottom);
- end;
-
- // check horizontal alignment
- x := rect.Left;
- ExtraSpaceTotal := 0;
- ExtraSpaceActual := 0;
- case aBlock.HorzAlign of
- tsHorzAlignCenter:
- x := rect.Left + (aBlock.Width div 2) - (line^.meta.Width div 2);
- tsHorzAlignRight:
- x := rect.Right - line^.meta.Width;
- tsHorzAlignJustify:
- if (tsAutoLineBreak in line^.Flags) then
- ExtraSpaceTotal := (aBlock.Width - line^.meta.Width) / line^.meta.SpaceCount;
- end;
-
- if DrawText then
- SetDrawPos(x, y + line^.meta.Ascent);
- inc(y, line^.meta.Height + line^.meta.Spacing);
- item := line^.First;
- while Assigned(item) do begin
- DrawItem;
- item := item^.Next;
- end;
- end;
-
- begin
- if (aBlock.Renderer <> self) then
- EtsException.Create('text block was created by other renderer');
-
- BeginRender;
- try
- // init variables
- y := aBlock.Top;
- font := nil;
- line := aBlock.Lines;
- rect := aBlock.Rect;
-
- // check vertical alignment
- case aBlock.VertAlign of
- tsVertAlignCenter:
- y := y + (aBlock.Height div 2 - aBlock.GetActualBlockHeight div 2);
- tsVertAlignBottom:
- y := y + (aBlock.Height - aBlock.GetActualBlockHeight);
- end;
-
- while Assigned(line) do begin
- DrawLine;
- line := line^.Next;
- end;
- finally
- EndRender;
- FreeAndNil(aBlock);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TtsRenderer.Create(const aContext: TtsContext; const aFormat: TtsFormat);
- begin
- inherited Create;
- fContext := aContext;
- fFormat := aFormat;
- fSaveImages := true;
- fBlocks := TObjectList.Create(false);
- fRenderCS := TCriticalSection.Create;
- fContext.RegisterRenderer(self);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TtsRenderer.Destroy;
- begin
- fContext.UnregisterRenderer(self);
- fBlocks.OwnsObjects := true;
- FreeAndNil(fBlocks);
- FreeAndNil(fRenderCS);
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TtsContext////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsContext.RegisterRenderer(const aRenderer: TtsRenderer);
- begin
- fRenderers.Add(aRenderer);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsContext.UnregisterRenderer(const aRenderer: TtsRenderer);
- begin
- if Assigned(fRenderers) then
- fRenderers.Remove(aRenderer);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsContext.RegisterGenerator(const aGenerator: TtsFontGenerator);
- begin
- fGenerators.Add(aGenerator);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsContext.UnregisterGenerator(const aGenerator: TtsFontGenerator);
- begin
- if Assigned(fGenerators) then
- fGenerators.Remove(aGenerator);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsContext.AnsiToWide(const aText: PAnsiChar): PWideChar;
- var
- len: Integer;
- begin
- result := nil;
- if not Assigned(aText) then
- exit;
- len := Length(aText);
- tsAnsiToWide(result, len, aText, fCodePage, fCodePageDefault);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TtsContext.Create;
- begin
- inherited Create;
-
- fCodePage := tsUTF8;
- fCodePageDefault := WideChar('?');
-
- fRenderers := TObjectList.Create(false);
- fGenerators := TObjectList.Create(false);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TtsContext.Destroy;
- begin
- fGenerators.OwnsObjects := true;
- fRenderers.OwnsObjects := true;
- FreeAndNil(fGenerators);
- FreeAndNil(fRenderers);
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //Exceptions////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor EtsOutOfRange.Create(const aMin, aMax, aIndex: Integer);
- begin
- inherited Create(Format('index (%d) is out of range (%d - %d)', [aIndex, aMin, aMax]));
- end;
-
- initialization
- Randomize;
-
- end.
-
|