unit UCharsetPool;

interface

uses
  Types,
  CoreExported,
  UPool,
  UTexturePool;

type
  TCharsetPool = class;

  TCharset = class (TPoolItem, ICharset)
    private type
      TChar = packed record
        X: Word;
      end;
      TLine = packed record
        Y, FirstChar: Word;
        Chars: packed array of TChar;
      end;
      TPage = record
        Texture: ITexture;
        FirstChar: Integer;
        Lines: array of TLine;
      end;
      TCharLine = array of record
        Texture: Pointer;
        X,Y, Width: Integer;
      end;
      PPixelLine = ^TPixelLine;
      TPixelLine = array [0..$FFFFFF] of Cardinal;

    private
      FTexturePool: TTexturePool;
      FCoreWindow: Pointer;
      FPages: array of TPage;
      FHeight: Integer;
      FCharLineWidth: Integer;
      FCount: Integer;

    protected
      function BuildCharLine (Str: PWideChar): TCharLine;

    public
      constructor Create (Pool: TCharsetPool; Path: PWideChar);
      destructor Destroy; override;

    procedure BuildStrTexture
                (Str: PWideChar;
                 TextColor, BgColor: Cardinal;
                 Align: TFloatPoint;
                 out Texture: ITexture;
                 out Extent, Offset: TFloatPoint); stdcall;
  end;

  TCharsetPool = class (TPool, ICharsetPool)
    private
      FTexturePool: TTexturePool;
      FCoreWindow: Pointer;

    protected
      function CreateItem (Path: PWideChar): TPoolItem; override;

    public
      constructor Create (Root: IInterface; TexturePool: TTexturePool);
      destructor Destroy; override;

    procedure LoadCharset (Path: PWideChar; out Charset: ICharset); stdcall;
  end;

implementation

uses
  SysUtils,
  Direct3D9;

function TCharset.BuildCharLine;
var
  i: Integer;
  Page, Line, Char: Integer;

  procedure FindPage (Ch: Word);
  begin
    Page := Length (FPages) - 1;
    while FPages [Page].FirstChar > Ch do
      Dec (Page);
  end;
  procedure FindLine (Ch: Word);
  begin
    FindPage (Ch);
    Line := Length (FPages [Page].Lines) - 1;
    while FPages [Page].Lines [Line].FirstChar > Ch do
      Dec (Line);
  end;
  procedure FindChar (Ch: Word);
  begin
    FindLine (Ch);
    Char := Ch - FPages [Page].Lines [Line].FirstChar;
  end;
begin
  FCharLineWidth := 0;
  SetLength (Result, StrLen (Str));
  for i := 0 to Length (Result) - 1 do
  begin
    FindChar (Word (Str [i]));
    with Result [i] do
    begin
      Texture := Pointer (FPages [Page].Texture);
      X := FPages [Page].Lines [Line].Chars [Char].X;
      Y := FPages [Page].Lines [Line].Y;
      Width := FPages [Page].Lines [Line].Chars [Char + 1].X - X;
      FCharLineWidth := FCharLineWidth + Width;
    end;
  end;
end;

constructor TCharset.Create;
const
  PageStart = 8;
  PageInc = 2;
  LineStart = 200;
  LineInc = 20;
  CharStart = 300;
  CharInc = 50;
var
  Input: Text;
  NextChar: Integer;
  Str: string;
  Cmd: string;
  Tag: Integer;
  CurrentPage, CurrentLine, CurrentChar: Integer;

  procedure Err (Condition: Boolean = True);
  begin
    if Condition
    then
      raise Exception.Create('Invalid input file: "' + string (Path) + '".');
  end;
  procedure CmdPage;
  begin
    if CurrentPage <> -1
    then
      SetLength (FPages [CurrentPage].Lines, CurrentLine + 1);
    CurrentPage := Tag;
    while CurrentPage >= Length (FPages) do
      SetLength (FPages, Length (FPages) + PageInc);
    SetLength (FPages [CurrentPage].Lines, LineStart);
    Pool.FTexturePool.LoadTexture (PWideChar (string (Path) + '.' + IntToStr (CurrentPage) + '.png'), FPages [CurrentPage].Texture);
    FPages [CurrentPage].FirstChar := NextChar;
    CurrentLine := -1;
    CurrentChar := -1;
  end;
  procedure CmdHeight;
  begin
    FHeight := Tag;
  end;
  procedure CmdLine;
  begin
    CurrentLine := Tag;
    while CurrentLine >= Length (FPages [CurrentPage].Lines) do
      SetLength (FPages [CurrentPage].Lines, Length (FPages [CurrentPage].Lines) + LineInc);
    FPages [CurrentPage].Lines [CurrentLine].FirstChar := NextChar;
    SetLength (FPages [CurrentPage].Lines [CurrentLine].Chars, CharStart);
    CurrentChar := 0;
  end;
  procedure CmdY;
  begin
    FPages [CurrentPage].Lines [CurrentLine].Y := Tag;
  end;
  procedure CmdX;
  begin
    while CurrentChar >= Length (FPages [CurrentPage].Lines [CurrentLine].Chars) do
      SetLength (FPages [CurrentPage].Lines [CurrentLine].Chars, Length (FPages [CurrentPage].Lines [CurrentLine].Chars) + CharInc);
    FPages [CurrentPage].Lines [CurrentLine].Chars [CurrentChar].X := Tag;
    Inc (CurrentChar);
    Inc (NextChar);
  end;
  procedure CmdWidth;
  begin
    SetLength (FPages [CurrentPage].Lines [CurrentLine].Chars, CurrentChar + 1);
    FPages [CurrentPage].Lines [CurrentLine].Chars [CurrentChar].X := Tag;
  end;
  procedure ProcessStr;
  var
    CPos: Integer;
  begin
    CPos := Pos ('=', Str);
    Err (CPos = 0);
    Cmd := UpperCase (Trim (Copy (Str, 1, CPos - 1)));
    Str := Trim (Copy (Str, CPos + 1, MaxInt));
    Val (Str, Tag, CPos);
    Err (CPos <> 0);
    if Cmd = 'X'
    then
      CmdX
    else if Cmd = 'LINE'
    then
      CmdLine
    else if Cmd = 'Y'
    then
      CmdY
    else if Cmd = 'WIDTH'
    then
      CmdWidth
    else if Cmd = 'PAGE'
    then
      CmdPage
    else if Cmd = 'HEIGHT'
    then
      CmdHeight
    else
      Err;
  end;
begin
  inherited Create (Pool, Path);
  FTexturePool := Pool.FTexturePool;
  FCoreWindow := Pool.FCoreWindow;
  AssignFile (Input, string (Path) + '.charset');
  Reset (Input);

  SetLength (FPages, PageStart);
  CurrentPage := -1;
  NextChar := 0;
  while NextChar <> $10000 do
  begin
    ReadLn (Input, Str);
    ProcessStr;
  end;
  ReadLn (Input, Str);
  ProcessStr;
  SetLength (FPages [CurrentPage].Lines [CurrentLine].Chars, CurrentChar + 1);
  SetLength (FPages [CurrentPage].Lines, CurrentLine + 1);
  SetLength (FPages, CurrentPage + 1);

  Close (Input);
end;

destructor TCharset.Destroy;
var
  i: Integer;
begin
  for i := 0 to Length (FPages) - 1 do
    FPages [i].Texture := nil;
  inherited Destroy;
end;

function CorrectSize (X: Integer): Integer;
begin
  Result := 1;
  Inc (X);
  while X >= 1 do
  begin
    Result := Result shl 1;
    X := X shr 1;
  end;
end;

procedure TCharset.BuildStrTexture;
var
  CharLine: TCharLine;
  TexPath: string;
  Source, Target: TD3DLockedRect;
  SrcRect, TgtRect: TRect;
  i, X,Y, Position: Integer;
  D3DTex, CharTex: IDirect3DTexture9;
  SrcLine, TgtLine: PPixelLine;
  Size, WinSize: TPoint;
begin
  Inc (FCount);
  TexPath := IntToStr (Integer (Self)) + IntToStr (FCount);
  CharLine := BuildCharLine (Str);
  Size.X := CorrectSize (FCharLineWidth);
  Size.Y := CorrectSize (FHeight);
  FTexturePool.CreateTexture (PWideChar (TexPath), Size.X, Size.Y, D3DFMT_A8R8G8B8, Texture);
  D3DTex := Texture.Direct3DTexture;
  FillChar (Target, SizeOf (TD3DLockedRect), 0);
  TgtRect.Top := 0;
  TgtRect.Left := 0;
  TgtRect.BottomRight := Size;
  ED3DError.Check (D3DTex.LockRect (0, Target, @TgtRect, 0));
  for i := 0 to Size.Y - 1 do
    FillChar (Pointer (Integer (Target.pBits) + i * Target.Pitch)^, 4 * Size.X, 0);
  Position := 0;
  for i := 0 to Length (CharLine) - 1 do
  begin
    SrcRect.Left := CharLine [i].X;
    SrcRect.Top := CharLine [i].Y;
    SrcRect.Right := TgtRect.Left + CharLine [i].Width;
    SrcRect.Bottom := TgtRect.Top + FHeight;
    CharTex := ITexture (CharLine [i].Texture).Direct3DTexture;
    ED3DError.Check (CharTex.LockRect (0, Source, @SrcRect, D3DLOCK_READONLY));
    SrcLine := Source.pBits;
    TgtLine := Pointer (Integer (Target.pBits) + 4 * Position);
    for Y := 0 to FHeight - 1 do
    begin
      for X := 0 to CharLine [i].Width - 1 do
        if SrcLine [X] and $FF = 0
        then
          TgtLine [X] := TextColor
        else
          TgtLine [X] := BgColor;
      SrcLine := Pointer (Integer (SrcLine) + Source.Pitch);
      TgtLine := Pointer (Integer (TgtLine) + Target.Pitch);
    end;
    ED3DError.Check (CharTex.UnlockRect (0));
    Position := Position + CharLine [i].Width;
  end;
  ED3DError.Check (D3DTex.UnlockRect (0));
  D3DTex := nil;
  CharTex := nil;
  WinSize := ICoreWindow (FCoreWindow).Size;
  Extent := TFloatPoint (Size) / WinSize.X;
  Offset.X := (Size.X + FCharLineWidth * (- 1 + Align.X)) / WinSize.X;
  Offset.Y := - (Size.Y + FHeight * (- 1 + Align.Y)) / WinSize.X;
end;



function TCharsetPool.CreateItem;
begin
  Result := TCharset.Create (Self, Path);
end;

constructor TCharsetPool.Create;
begin
  inherited Create (Root);
  FCoreWindow := Pointer (Root);
  FTexturePool := TexturePool;
end;

destructor TCharsetPool.Destroy;
begin
  inherited Destroy;
end;

procedure TCharsetPool.LoadCharset;
begin
  Charset := LoadItem (Path) as ICharset;
end;

end.