TextSuite/new/utsTextSuite.pas

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;
    fCreator: 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 aCreator: 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 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;
    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
    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
    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 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;
    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
  );
  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;
  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
    fID: Cardinal;

    fCodePage: TtsCodePage;
    fCodePagePtr: Pointer;
    fCodePageFunc: TtsAnsiToWideCharFunc;
    fCodePageDefault: WideChar;
  public
    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

var
  gLastContextID: Cardinal = 0;

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);
  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: Integer;
begin
  ImgSize := aImage.Width * aImage.Height * tsFormatSize(aImage.Format);
  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;
begin
  ImgData := AllocMem(aWidth * aHeight * tsFormatSize(aFormat));
  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 aCreator: TtsFontGenerator; const aProperties: TtsFontProperties);
begin
  inherited Create;
  fRenderer     := aRenderer;
  fCreator      := aCreator;
  fProperties   := aProperties;
  fCharSpacing  := 0;
  fTabWidth     := 0;
  fLineSpacing  := 0.0;
  fCreateChars  := true;
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 := fCreator.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;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
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
  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;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
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;
begin
  inherited Create;
  fPostProcessSteps := TObjectList.Create(true);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TtsFontGenerator.Destroy;
begin
  ClearPostProcessSteps;
  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;
          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;

  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);
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.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:
        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
  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;
  fRenderCS   := TCriticalSection.Create;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TtsRenderer.Destroy;
begin
  FreeAndNil(fRenderCS);
  inherited Destroy;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TtsContext////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsContext.AnsiToWide(const aText: PAnsiChar): PWideChar;
var
  len: Integer;
begin
  result := nil;

  if not Assigned(aText) then
    exit;
  len := Length(aText);

  // UTF-8
  if (fCodePage = tsUTF8) then begin
    result := tsStrAlloc(len);
    tsUTF8ToWide(result, len, aText, fCodePageDefault);

  // ISO 8859-1
  end else if (fCodePage = tsISO_8859_1) then begin
    result := tsStrAlloc(len);
    tsISO_8859_1ToWide(result, len, aText);

    // single or double byte CodePage
  end else if Assigned(fCodePageFunc) and Assigned(fCodePagePtr) then begin
    result := tsStrAlloc(len);
    fCodePageFunc(result, len, aText, fCodePage, fCodePageDefault);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TtsContext.Create;
begin
  inherited Create;

  fID := InterLockedIncrement(gLastContextID);

  fCodePage        := tsUTF8;
  fCodePageFunc    := nil;
  fCodePagePtr     := nil;
  fCodePageDefault := WideChar('?');
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TtsContext.Destroy;
begin
  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.