unit utsCharCache;

{$IFDEF FPC}
  {$mode objfpc}{$H+}
{$ENDIF}

interface

uses
  Classes, SysUtils,
  utsChar, utsFont, utsUtils, utsContext, utsTypes, utsImage;

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TtsCharArray = packed record
    Chars: array [Byte] of TtsChar;
    Count: Byte;
  end;
  PtsCharArray = ^TtsCharArray;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TtsRenderRefGenerator = class(TtsRefManager)
  private
    fContext: TtsContext;
    fFormat: TtsFormat;
  public
    property Context: TtsContext read fContext;
    property Format:  TtsFormat  read fFormat;

    function  CreateRenderRef(const aChar: TtsChar; const aImage: TtsImage): TtsRenderRef; virtual; abstract;
    procedure FreeRenderRef(const aRenderRef: TtsRenderRef); virtual; abstract;

    constructor Create(const aContext: TtsContext; const aFormat: TtsFormat);
  end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TtsChars = class(TObject)
  private
    fRenderRefGenerator: TtsRenderRefGenerator;
    fFont: TtsFont;
    fCanCreate: Boolean;
    fChars: array[Byte] of PtsCharArray;
    function GenerateChar(const aCharCode: WideChar): TtsChar;
  public
    function GetChar(const aCharCode: WideChar): TtsChar;
    function AddChar(const aCharCode: WideChar): TtsChar;
    procedure DelChar(const aCharCode: WideChar);
    procedure AddCharRange(const aStart, aStop: WideChar);
    procedure DelCharRange(const aStart, aStop: WideChar);
    procedure Clear;
  public
    property CanCreate: Boolean read fCanCreate write fCanCreate;
    property Char[const aCharCode: WideChar]: TtsChar read GetChar;

    function GetTextWidthW(aText: PWideChar): Integer;
    function GetTextWidthA(aText: PAnsiChar): Integer;

    constructor Create(const aRenderRefGen: TtsRenderRefGenerator; const aFont: TtsFont);
    destructor Destroy; override;
  end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  PtsCharCacheItem = ^TtsCharCacheItem;
  TtsCharCacheItem = packed record
    key: TtsFont;
    val: TtsChars;
  end;

  TtsCharCache = class(TtsRefManager)
  private
    fRenderRefGenerator: TtsRenderRefGenerator;
    fItems: TList;
    function GetChars(const aKey: TtsFont): TtsChars;
    function Find(const aMin, aMax: Integer; const aKey: TtsFont; out aIndex: Integer): Integer;
  protected
    function DelSlave(const aSlave: TtsRefManager): Boolean; override;
  public
    property Chars[const aKey: TtsFont]: TtsChars read GetChars;

    procedure Clear;

    constructor Create(const aRenderRefGen: TtsRenderRefGenerator);
    destructor Destroy; override;
  end;

implementation

uses
  Math,
  utsConstants;

type
  TtsWritableChar = class(TtsChar)
  public
    property RenderRef: TtsRenderRef read fRenderRef write fRenderRef;
  end;


{$IFNDEF fpc}
  {$IFDEF WIN64}
  PtrUInt   = System.UInt64;
  {$ELSE}
  PtrUInt = Cardinal;
  {$ENDIF}
{$ENDIF}

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TtsChars//////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsChars.GenerateChar(const aCharCode: WideChar): TtsChar;
var
  GlyphSize: TtsPosition;
  CharImage: TtsImage;
  m: TtsGlyphMetric;
  c: TtsWritableChar;

  procedure FillLine(aData: PByte);
  var
    w, i: Integer;
    c: TtsColor4f;
    tmp: PByte;
  begin
    w := CharImage.Width;
    while (w > 0) do begin
      tmp := aData;
      tsFormatUnmap(CharImage.Format, tmp, c);
      for i := 0 to 3 do
        c.arr[i] := 1.0;
      tsFormatMap(CharImage.Format, aData, c);
      dec(w);
    end;
  end;

  procedure DrawLine(aLinePosition, aLineSize: Integer);
  var
    ImgSize, ImgPos, Origin: TtsPosition;
    Rect: TtsRect;
    YOffset, y: Integer;
  begin
    if aLineSize <= 0 then
      exit;

    aLinePosition := aLinePosition - aLineSize;

    // calculate width and height
    ImgPos  := tsPosition(0, 0);
    ImgSize := tsPosition(CharImage.Width, CharImage.Height);
    Origin  := m.GlyphOrigin;
    Rect    := m.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 < m.Advance) then begin
      Rect.Right := Rect.Left + m.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;
    CharImage.Resize(ImgSize.x, ImgSize.y, ImgPos.x, ImgPos.y);

    // draw lines
    YOffset := Rect.Top + Origin.y - aLinePosition;
    for y := 1 to aLineSize do
      FillLine(CharImage.ScanLine[YOffset - y]);

    // move glyph rect
    m.GlyphOrigin := Origin;
    m.GlyphRect   := Rect;
  end;

begin
  result := nil;
  if (aCharCode <> #0) and
     (not fFont.GetGlyphMetrics(aCharCode, m.GlyphOrigin, GlyphSize, m.Advance) or
      not ((m.GlyphOrigin.x <> 0) or
           (m.GlyphOrigin.y <> 0) or
           (GlyphSize.x <> 0) or
           (GlyphSize.y <> 0) or
           (m.Advance <> 0))) then
        exit;

  CharImage := TtsImage.Create(nil);
  try
    if (aCharCode = #0) then begin
      CharImage.CreateEmpty(fRenderRefGenerator.Format, 3, 1);
      m.GlyphOrigin := tsPosition(0, 1);
      m.Advance     := 1;
    end else if (GlyphSize.x > 0) and (GlyphSize.y > 0) then
      fFont.GetCharImage(aCharCode, CharImage, fRenderRefGenerator.Format);

    if CharImage.IsEmpty and ([tsStyleUnderline, tsStyleStrikeout] * fFont.Metric.Style <> []) then begin
      CharImage.CreateEmpty(fRenderRefGenerator.Format, max(m.Advance, 1), 1);
      m.GlyphOrigin.y := 1;
    end;

    c := TtsWritableChar.Create(aCharCode);
    try
      if (aCharCode = #0)
        then m.GlyphRect := tsRect(1, 0, 2, 1)
        else m.GlyphRect := tsRect(0, 0, CharImage.Width, CharImage.Height);

      try
        if (tsStyleUnderline in fFont.Metric.Style) then
          DrawLine(fFont.Metric.UnderlinePos, fFont.Metric.UnderlineSize);
        if (tsStyleStrikeout in fFont.Metric.Style) then
          DrawLine(fFont.Metric.StrikeoutPos, fFont.Metric.StrikeoutSize);
      except
        CharImage.FillColor(tsColor4f(1, 0, 0, 0), TS_COLOR_CHANNELS_RGB, TS_IMAGE_MODES_MODULATE_ALPHA);
      end;

      c.GlyphMetric := m;
      if Assigned(fFont.PostProcessor) then
        fFont.PostProcessor.Execute(c, CharImage);
      c.RenderRef := fRenderRefGenerator.CreateRenderRef(c, CharImage);
      result := c;
    except
      FreeAndNil(c);
    end;
  finally
    FreeAndNil(CharImage);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsChars.GetChar(const aCharCode: WideChar): TtsChar;
var
  arr: PtsCharArray;
begin
  arr := fChars[(Ord(aCharCode) shr 8) and $FF];
  if Assigned(arr) then
    result := arr^.Chars[Ord(aCharCode) and $FF]
  else
    result := nil;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsChars.AddChar(const aCharCode: WideChar): TtsChar;
var
  h, l: Integer;
  arr: PtsCharArray;
begin
  result := GetChar(aCharCode);
  if not Assigned(result) and fCanCreate then begin
    result := GenerateChar(aCharCode);
    if Assigned(result) then begin
      h := (Ord(aCharCode) shr 8) and $FF;
      arr := fChars[h];
      if not Assigned(arr) then begin
        New(arr);
        FillChar(arr^, SizeOf(arr^), 0);
        fChars[h] := arr;
      end;
      l := Ord(aCharCode) and $FF;
      arr^.Chars[l] := result;
      inc(arr^.Count);
    end;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsChars.DelChar(const aCharCode: WideChar);
var
  h, l: Integer;
  c: TtsChar;
  arr: PtsCharArray;
begin
  // find char array
  h := (Ord(aCharCode) shr 8) and $FF;
  arr := fChars[h];
  if not Assigned(arr) then
    exit;

  // find char
  l := Ord(aCharCode) and $FF;
  c := arr^.Chars[l];
  if not Assigned(c) then
    exit;

  // remove char
  arr^.Chars[l] := nil;
  dec(arr^.Count);
  if (arr^.Count <= 0) then begin
    fChars[h] := nil;
    Dispose(arr);
  end;

  if Assigned(c.RenderRef) then
    fRenderRefGenerator.FreeRenderRef(c.RenderRef);
  FreeAndNil(c);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsChars.AddCharRange(const aStart, aStop: WideChar);
var
  c: WideChar;
begin
  for c := aStart to aStop do
    AddChar(c);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsChars.DelCharRange(const aStart, aStop: WideChar);
var
  c: WideChar;
begin
  for c := aStart to aStop do
    DelChar(c);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsChars.Clear;
var
  h, l: Integer;
  c: TtsChar;
  arr: PtsCharArray;
begin
  for h := Low(fChars) to High(fChars) do begin
    arr := fChars[h];
    if Assigned(arr) then begin
      for l := Low(arr^.Chars) to High(arr^.Chars) do begin
        c := arr^.Chars[l];
        if Assigned(c) then begin
          if Assigned(c.RenderRef) then
            fRenderRefGenerator.FreeRenderRef(c.RenderRef);
          FreeAndNil(c);
        end;
      end;
      Dispose(arr);
      fChars[h] := nil;
    end;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsChars.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(fRenderRefGenerator.Context.DefaultChar);
    if Assigned(c) then begin
      if (result > 0) then
        result := result + fFont.CharSpacing;
      result := result + c.GlyphMetric.Advance;
    end;
    inc(aText);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsChars.GetTextWidthA(aText: PAnsiChar): Integer;
var
  tmp: PWideChar;
begin
  tmp := fRenderRefGenerator.Context.AnsiToWide(aText);
  try
    result := GetTextWidthW(tmp);
  finally
    tsStrDispose(tmp);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TtsChars.Create(const aRenderRefGen: TtsRenderRefGenerator; const aFont: TtsFont);
begin
  inherited Create;
  fRenderRefGenerator := aRenderRefGen;
  fFont               := aFont;
  fCanCreate          := true;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TtsChars.Destroy;
begin
  Clear;
  inherited Destroy;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TtsRenderRefGenerator/////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TtsRenderRefGenerator.Create(const aContext: TtsContext; const aFormat: TtsFormat);
begin
  inherited Create(aContext);
  fContext := aContext;
  fFormat  := aFormat;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TtsCharCache//////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsCharCache.GetChars(const aKey: TtsFont): TtsChars;
var
  pos, index: Integer;
  p: PtsCharCacheItem;
begin
  pos := Find(0, fItems.Count-1, aKey, index);
  if (pos < 0) then begin
    result := TtsChars.Create(fRenderRefGenerator, aKey);
    aKey.AddMaster(self);
    new(p);
    p^.key := aKey;
    p^.val := result;
    fItems.Insert(index, p);
  end else
    result := PtsCharCacheItem(fItems[pos])^.val;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsCharCache.Find(const aMin, aMax: Integer; const aKey: TtsFont; out aIndex: Integer): Integer;
var
  i: Integer;
begin
  if (aMin <= aMax) then begin
    i := aMin + Trunc((aMax - aMin) / 2);
    if (aKey = PtsCharCacheItem(fItems[i])^.key) then
      result := i
    else if (PtrUInt(aKey) < PtrUInt(PtsCharCacheItem(fItems[i])^.key)) then
      result := Find(aMin, i-1, aKey, aIndex)
    else
      result := Find(i+1, aMax, aKey, aIndex);
  end else begin
    result := -1;
    aIndex := aMin;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsCharCache.DelSlave(const aSlave: TtsRefManager): Boolean;
var
  f: TtsFont;
  pos, index: Integer;
  p: PtsCharCacheItem;
begin
  f := (aSlave as TtsFont);
  f.DelMaster(self);
  pos := Find(0, fItems.Count-1, f, index);
  if (pos >= 0) then begin
    p := PtsCharCacheItem(fItems[pos]);
    fItems.Delete(pos);
    FreeAndNil(p^.val);
    Dispose(p);
  end;
  result := inherited DelSlave(aSlave);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsCharCache.Clear;
var
  p: PtsCharCacheItem;
  i: Integer;
begin
  for i := 0 to fItems.Count-1 do begin
    p := PtsCharCacheItem(fItems[i]);
    p^.key.DelMaster(self);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TtsCharCache.Create(const aRenderRefGen: TtsRenderRefGenerator);
begin
  inherited Create(aRenderRefGen);
  fRenderRefGenerator := aRenderRefGen;
  fItems              := TList.Create;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TtsCharCache.Destroy;
begin
  Clear;
  FreeAndNil(fItems);
  inherited Destroy;
end;

end.