|
- unit utsTextSuite;
-
- {$IFDEF FPC}
- {$mode delphi}{$H+}
- {$ENDIF}
-
- 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;
- end;
-
- TtsKernel1D = class
- public
- Size: Integer;
- Items: array of TtsKernel1DItem;
- ItemCount: Integer;
- constructor Create(const aRadius, aStrength: Single);
- end;
-
- TtsKernel2DItem = packed record
- OffsetX: Integer;
- OffsetY: Integer;
- Value: Double;
- DataOffset: Integer;
- end;
-
- TtsKernel2D = class
- public
- SizeX: Integer;
- SizeY: Integer;
-
- MidSizeX: Integer;
- MidSizeY: Integer;
-
- ValueSum: Double;
-
- Items: array of TtsKernel2DItem;
- 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;
- fDataSize: Integer;
- fLineSize: 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;
- const aLineSize: Integer = 0; const aDataSize: Integer = 0);
- procedure UpdateScanlines;
- public
- property IsEmpty: Boolean read GetIsEmpty;
- property Width: Integer read fWidth;
- property Height: Integer read fHeight;
- property LineSize: Integer read fLineSize;
- property DataSize: Integer read fDataSize;
- 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 Blend(const aImage: TtsImage; const X, Y: Integer; const aFunc: TtsBlendFunc);
- procedure Blur(const aHorzKernel, aVertKernel: TtsKernel1D; const aChannelMask: TtsColorChannels);
-
- 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);
- protected
- procedure Execute(const aChar: TtsChar; const aCharImage: TtsImage); virtual; abstract;
- public
- function IsInRange(const aCharCode: WideChar): Boolean;
-
- 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): 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; const aForcedWidth: Integer = 0); 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;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TtsKernel2D///////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TtsKernel2D.Create(const aRadius, aStrength: Single);
- var
- tmpStrenght: Double;
- tmpRadius: Double;
- tmpValue: Double;
- sqrRadius: Double;
- x, y, w, h: Integer;
-
- function CalcValue(const aIndex: Double): Double;
- begin
- result := max(0, Abs(aIndex) - tmpStrenght);
- result := Sqr(result * tmpRadius) / sqrRadius;
- result := Exp(-result);
- end;
-
- procedure CalcSize(var aSize, aMidSize: Integer);
- begin
- aSize := 0;
- aMidSize := 0;
- while CalcValue(aSize) > 0.5 do begin
- inc(aSize, 1);
- inc(aMidSize, 1);
- end;
- while CalcValue(aSize) > 0.001 do
- Inc(aSize, 1);
- end;
-
- procedure SetItem(const x, y: Integer);
- begin
- with Items[(SizeY + y) * w + (SizeX + x)] do begin
- OffsetX := x;
- OffsetY := y;
- Value := tmpValue;
- end;
- end;
-
- procedure QuickSort(l, r: Integer);
- var
- _l, _r: Integer;
- p, t: TtsKernel2DItem;
- begin
- repeat
- _l := l;
- _r := r;
- p := Items[(l + r) shr 1];
-
- repeat
- while (Items[_l].Value > p.Value) do
- inc(_l, 1);
-
- while (Items[_r].Value < p.Value) do
- dec(_r, 1);
-
- if (_l <= _r) then begin
- t := Items[_l];
- Items[_l] := Items[_r];
- Items[_r] := t;
- inc(_l, 1);
- dec(_r, 1);
- end;
- until (_l > _r);
-
- if (l < _r) then
- QuickSort(l, _r);
-
- l := _l;
- until (_l >= r);
- end;
-
- begin
- inherited Create;
-
- tmpStrenght := Min(aRadius - 1.0, aRadius * aStrength);
- tmpRadius := aRadius - tmpStrenght;
- sqrRadius := sqr(tmpRadius) * sqr(tmpRadius);
-
- CalcSize(SizeX, MidSizeX);
- CalcSize(SizeY, MidSizeY);
-
- ValueSum := 0.0;
- w := 2 * SizeX + 1;
- h := 2 * SizeY + 1;
- ItemCount := w * h;
- SetLength(Items, ItemCount);
-
- for y := 0 to SizeY do begin
- for x := 0 to SizeX do begin
- tmpValue := CalcValue(sqrt(Sqr(x) + Sqr(y)));
-
- SetItem( x, y);
- SetItem( x, -y);
- SetItem(-x, -y);
- SetItem(-x, y);
-
- ValueSum := ValueSum + tmpValue;
- if (x > 0) and (y > 0) then
- ValueSum := ValueSum + tmpValue;
- end;
- end;
-
- QuickSort(0, ItemCount-1);
-
- while (Items[ItemCount-1].Value < 0.001) do
- dec(ItemCount, 1);
- SetLength(Items, ItemCount);
- 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; const aLineSize: Integer; const aDataSize: Integer);
- begin
- fHasScanlines := false;
- if Assigned(fData) then
- FreeMemory(fData);
-
- fData := aData;
- if Assigned(fData) then begin
- fWidth := aWidth;
- fHeight := aHeight;
- fFormat := aFormat;
- fLineSize := aLineSize;
- fDataSize := aDataSize;
- end else begin
- fWidth := 0;
- fHeight := 0;
- fLineSize := 0;
- fDataSize := 0;
- fFormat := tsFormatEmpty;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsImage.UpdateScanlines;
- var
- i: Integer;
- tmp: PByte;
- begin
- SetLength(fScanlines, fHeight);
- for i := 0 to fHeight-1 do begin
- tmp := fData;
- inc(tmp, i * fLineSize);
- 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;
- begin
- GetMem(ImgData, aImage.DataSize);
- if Assigned(ImgData) then
- Move(aImage.Data^, ImgData^, aImage.DataSize);
- SetData(ImgData, aImage.Format, aImage.Width, aImage.Height, aImage.LineSize, aImage.DataSize);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsImage.CreateEmpty(const aFormat: TtsFormat; const aWidth, aHeight: Integer);
- var
- ImgData: PByte;
- lSize, dSize: Integer;
- begin
- lSize := aWidth * tsFormatSize(aFormat);
- lSize := lSize + ((4 - (lSize mod 4)) mod 4);
- dSize := aHeight * lSize;
- ImgData := AllocMem(dSize);
- FillChar(ImgData^, dSize, #0);
- SetData(ImgData, aFormat, aWidth, aHeight, lSize, dSize);
- 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;
- pSize, lSize, dSize: Integer;
-
- src, dst: PByte;
- YStart, YEnd, YPos, XStart, XEnd: Integer;
- begin
- if (aNewHeight = 0) or (aNewWidth = 0) then begin
- SetData(nil);
- exit;
- end;
-
- pSize := tsFormatSize(Format);
- lSize := pSize * aNewWidth;
- lSize := lSize + ((4 - (lSize mod 4)) mod 4);
- dSize := lSize * aNewHeight;
-
- GetMem(ImgData, dSize);
- try
- FillChar(ImgData^, dSize, 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, lSize * YPos + pSize * XStart);
-
- src := fData;
- Inc(src, fLineSize * (YPos - Y) + pSize * (XStart - X));
-
- Move(src^, dst^, (XEnd - XStart) * pSize);
- end;
-
- // assign
- SetData(ImgData, Format, aNewWidth, aNewHeight, lSize, dSize);
- 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;
- rp, wp: PByte;
- c: TtsColor4f;
- ch: TtsColorChannel;
- i: Integer;
- begin
- for y := 0 to Height-1 do begin
- rp := Scanline[y];
- wp := rp;
- for x := 0 to Width-1 do begin
- tsFormatUnmap(Format, rp, 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;
- tsFormatMap(Format, wp, c);
- 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(aPattern.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.Blend(const aImage: TtsImage; const X, Y: Integer; const aFunc: TtsBlendFunc);
- var
- _x, _y, x1, x2, y1, y2: Integer;
- src, dst, tmp: PByte;
- srcColor, dstColor: TtsColor4f;
- srcPixelSize, dstPixelSize: Integer;
- begin
- x1 := Max(X, 0);
- x2 := Min(X + aImage.Width , Width);
- y1 := Max(Y, 0);
- y2 := Min(Y + aImage.Height, Height);
- srcPixelSize := tsFormatSize(aImage.Format);
- dstPixelSize := tsFormatSize(Format);
- for _y := y1 to y2-1 do begin
- src := aImage.Scanline[_y - min(y1, y)];
- dst := Scanline[_y];
- inc(src, (x1 - x) * srcPixelSize);
- inc(dst, x1 * dstPixelSize);
- tmp := dst;
- for _x := x1 to x2-1 do begin
- tsFormatUnmap(aImage.Format, src, srcColor);
- tsFormatUnmap( Format, dst, dstColor);
- tsFormatMap(aImage.Format, tmp, aFunc(srcColor, dstColor));
- end;
- 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;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- 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;
- fGlyphOrigin := tsPosition(0, 0);
- fGlyphRect := tsRect(0, 0, 0, 0);
- fAdvance := 0;
- fRenderRef := nil;
- 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
- Chars := fChars[(Ord(aCharCode) shr 8) and $FF];
- if Assigned(Chars) then
- result := Chars^.Chars[Ord(aCharCode) and $FF]
- 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 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
- ImgSize, ImgPos, Origin: TtsPosition;
- Rect: TtsRect;
- YOffset, y: Integer;
-
- procedure FillLine(aData: PByte);
- var
- w, i: Integer;
- c: TtsColor4f;
- tmp: PByte;
- begin
- w := aCharImage.Width;
- 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
- ImgPos := tsPosition(0, 0);
- ImgSize := tsPosition(aCharImage.Width, aCharImage.Height);
- Origin := aChar.GlyphOrigin;
- Rect := aChar.GlyphRect;
-
- // expand left rect border to origin
- if (Origin.x > 0) then begin
- dec(Rect.Left, Origin.x);
- Origin.x := 0;
- end;
-
- // expand right rect border to advanced
- if (Rect.Right - Rect.Left < aChar.Advance) then begin
- Rect.Right := Rect.Left + aChar.Advance;
- end;
-
- // expand bottom rect border
- if (Origin.y - aLinePosition > Rect.Bottom) then begin
- Rect.Bottom := Origin.y - aLinePosition;
- end;
-
- // expand top rect border
- if (Origin.y - aLinePosition - aLineSize < Rect.Top) then begin
- Rect.Top := Origin.y - aLinePosition - aLineSize;
- Origin.y := aLinePosition + aLineSize;
- end;
-
- // update image size
- if (Rect.Right - Rect.Left > ImgSize.x) then begin
- ImgSize.x := Rect.Right - Rect.Left;
- ImgPos.x := Max(-Rect.Left, 0);
- inc(Rect.Left, ImgPos.x);
- inc(Rect.Right, ImgPos.x);
- end;
- if (Rect.Bottom - Rect.Top > ImgSize.y) then begin
- ImgSize.y := Rect.Bottom - Rect.Top;
- ImgPos.y := Max(-Rect.Top, 0);
- inc(Rect.Top, ImgPos.y);
- inc(Rect.Bottom, ImgPos.y);
- end;
- aCharImage.Resize(ImgSize.x, ImgSize.y, ImgPos.x, ImgPos.y);
-
- // draw lines
- YOffset := Rect.Top + Origin.y - aLinePosition;
- for y := 1 to aLineSize do
- FillLine(aCharImage.ScanLine[YOffset - y]);
-
- // move glyph rect
- aChar.GlyphOrigin := Origin;
- aChar.GlyphRect := Rect;
- 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 (aCharCode <> #0) and
- (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 (aCharCode = #0) then begin
- CharImage.CreateEmpty(aRenderer.Format, 3, 1);
- GlyphOrigin := tsPosition(0, 1);
- Advance := 1;
- end else if (GlyphSize.x > 0) and (GlyphSize.y > 0) then
- GetCharImage(aFont, aCharCode, CharImage);
-
- if CharImage.IsEmpty and ([tsStyleUnderline, tsStyleStrikeout] * aFont.Properties.Style <> []) then begin
- CharImage.CreateEmpty(aRenderer.Format, max(Advance, 1), 1);
- GlyphOrigin.y := 1;
- end;
- end;
-
- result := TtsChar.Create(aCharCode);
- try
- result.GlyphOrigin := GlyphOrigin;
- result.Advance := Advance;
- if (aCharCode = #0) then
- result.GlyphRect := tsRect(1, 0, 2, 1)
- else
- result.GlyphRect := tsRect(0, 0, CharImage.Width, CharImage.Height);
-
- if (aRenderer.SaveImages) then begin
- try
- if (tsStyleUnderline in aFont.Properties.Style) then
- DrawLine(result, CharImage, aFont.Properties.UnderlinePos, aFont.Properties.UnderlineSize);
- if (tsStyleStrikeout 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): 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);
- FillChar(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);
- FillChar(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) 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);
- FillChar(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);
- FillChar(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);
- FillChar(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;
- draw: 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 draw and Assigned(font) then begin
- c := item^.Text;
- while (c^ <> #0) do begin
- char := GetChar(c^);
- if Assigned(char) then begin
- MoveDrawPos(0, -metric.BaseLineOffset);
- Render(char.RenderRef);
- MoveDrawPos(char.Advance + font.CharSpacing, metric.BaseLineOffset);
- end;
- inc(c);
- end;
- end;
- end;
-
- tsItemTypeSpace: begin
- if draw 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(0, -metric.BaseLineOffset);
- Render(char.RenderRef);
- MoveDrawPos(char.Advance + 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
- char := GetChar(#0);
- if Assigned(char) then
- Render(char.RenderRef, tmp);
- // 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:
- draw := (y + line^.meta.Height > rect.Top) and (y < rect.Bottom);
- tsClipCharComplete, tsClipWordComplete:
- draw := (y > rect.Top) and (y + line^.meta.Height < rect.Bottom);
- else
- draw := true;
- 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) and (line^.meta.SpaceCount > 0) then
- ExtraSpaceTotal := (aBlock.Width - line^.meta.Width) / line^.meta.SpaceCount;
- end;
-
- if draw 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);
- result := tsStrAlloc(len);
- 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.
|