//DJXFonts v1.0
unit DJXFonts;

interface

uses
  Classes,
  Windows,
  Controls,
  SysUtils,
  DJXClasses,
  DJXRender,
  Direct3D9,
  D3DX9;
  

type
  TDJXFont = class(TObject)
  private
    m_DanJetX: Pointer;
    m_D3DXFontNormal: ID3DXFont;
    m_D3DXFontBold: ID3DXFont;
    m_D3DXFontItalic: ID3DXFont;
    m_D3DXFontBoldItalic: ID3DXFont;
    m_Size: integer;
    m_Name: string;
    procedure Release;
    procedure OnLostDevice;
    procedure OnResetDevice;
  public
    constructor Create(DanJetX: Pointer);
    destructor Destroy; override;
    property Name: string read m_Name write m_Name;
    procedure SetFont(FontName: string; Size: integer);
    procedure Print(
      x,y: integer;
      Text: string;
      Color: DWORD = $ffffffff;
      Bold: boolean = false;
      Italic: boolean = false
    );
    function  ParagraphFast(
      x,y: integer;
      Width,Height: integer;
      Text: string;
      Color: DWORD = $ffffffff;
      Bold: boolean = false;
      Italic: boolean = false;
      HAlign: TAlign = alLeft;
      VAlign: TAlign = alTop
    ) : integer;
    procedure  Paragraph(
      x,y: integer;
      Width: integer;
      Text: string
    );
    function GetTextWidth(
      Text: string;
      bold: boolean = false;
      Italic: boolean = false
    ): integer;
    function GetTextHeight(
      Text: string;
      bold: boolean = false;
      Italic: boolean = false
    ): integer;
  end;



  TDJXFontList = class(TDJXComponent)
  protected
    m_Fonts: Tlist;
    function getItem(Index: integer): TDJXFont;
    procedure setItem(Index: integer; Value: TDJXFont);
  public
    property DanJetX: Pointer read m_DanJetX write m_DanJetX;
    function CreateFont(NameInList: string; FontName: string; Size: integer): TDJXFont;
    property Fonts[Index: integer]:TDJXFont read getItem write setItem;
    function Find(name: string): TDJXFont;
    procedure Add(Font: TDJXFont);
    procedure Init(DanJetX: Pointer); override;
    procedure OnLostDevice; override;
    procedure OnResetDevice; override;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
  end;

implementation

uses
  DJX;

type
  TColTag = record
    Tag: string;
    Value: DWORD;
  end;

const
  ColTags: array[0..5] of TColTag =
  (
    (Tag: '<black>';  Value: $ff000000),
    (Tag: '<white>';  Value: $ffffffff),
    (Tag: '<red>';    Value: $ffff0000),
    (Tag: '<lime>';   Value: $ff00ff00),
    (Tag: '<blue>';   Value: $ff0000ff),
    (Tag: '<yellow>'; Value: $ffffff00)
  );


//TDJXFontList BEGIN

constructor TDJXFontList.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
end;
destructor TDJXFontList.Destroy;
begin
  if m_Fonts <> nil then
  begin
    while m_Fonts.Count > 0 do
    begin
      TDJXFont(m_Fonts.Items[0]).Free;
      m_Fonts.Delete(0);
    end;
    m_Fonts.Free;
  end;
  inherited Destroy;
end;
procedure TDJXFontList.Init(DanJetX: Pointer);
begin
  m_Fonts := Tlist.Create;
  inherited Init(DanJetX);
end;
procedure TDJXFontList.OnLostDevice;
var
  i: integer;
begin
  for i := 0 to m_Fonts.Count - 1 do
  TDJXFont(m_Fonts.Items[i]).OnLostDevice;
end;
procedure TDJXFontList.OnResetDevice;
var
  i: integer;
begin
  for i := 0 to m_Fonts.Count - 1 do
  TDJXFont(m_Fonts.Items[i]).OnResetDevice;
end;
procedure TDJXFontList.Add(Font: TDJXFont);
begin
  m_Fonts.Add(Font);
end;
function TDJXFontList.Find(name: string): TDJXFont;
var
  i: integer;
begin
  for i := 0 to m_Fonts.Count - 1 do
  if TDJXFont(m_Fonts.Items[i]).Name = name then
  begin
    result := TDJXFont(m_Fonts.Items[i]);
    exit;
  end;
  result := nil;
end;
function TDJXFontList.getItem(Index: integer): TDJXFont;
begin
  result := TDJXFont(m_Fonts.items[Index]);
end;
procedure TDJXFontList.setItem(Index: integer; Value: TDJXFont);
begin
  m_Fonts.items[Index] := Value;
end;
function TDJXFontList.CreateFont(NameInList: string;FontName: string;Size: integer): TDJXFont;
var
  DJXFont: TDJXFont;
begin
  DJXFont := TDJXFont.create(m_DanJetX);
  DJXFont.SetFont(FontName, Size);
  DJXFont.Name := NameInList;
  m_Fonts.Add(DJXFont);
  Result := DJXFont;
end;
//TDJXFontList END

//DJXFont BEGIN
procedure TDJXFont.OnLostDevice;
begin
  m_D3DXFontNormal.OnLostDevice;
  m_D3DXFontBold.OnLostDevice;
  m_D3DXFontItalic.OnLostDevice;
  m_D3DXFontBoldItalic.OnLostDevice;
end;
procedure TDJXFont.OnResetDevice;
begin
  m_D3DXFontNormal.OnResetDevice;
  m_D3DXFontBold.OnResetDevice;
  m_D3DXFontItalic.OnResetDevice;
  m_D3DXFontBoldItalic.OnResetDevice;
end;
function TDJXFont.GetTextWidth(
      Text: string;
      bold: boolean = false;
      Italic: boolean = false
    ): integer;
var
  FontUsed: ID3DXFont;
  Size: TSize;
begin
  if Bold and Italic then
  FontUsed := m_D3DXFontBoldItalic
  else
  if Bold then
  FontUsed := m_D3DXFontBold
  else
  if Italic then
  FontUsed := m_D3DXFontItalic
  else
  FontUsed := m_D3DXFontNormal;

  GetTextExtentPoint32(FontUsed.GetDC, PChar(Text), length(Text)*sizeof(Char), Size);

  result := Size.cx;

  FontUsed := nil;
end;
function TDJXFont.GetTextHeight(
      Text: string;
      bold: boolean = false;
      Italic: boolean = false
    ): integer;
var
  FontUsed: ID3DXFont;
  Size: TSize;
begin
  if Bold and Italic then
  FontUsed := m_D3DXFontBoldItalic
  else
  if Bold then
  FontUsed := m_D3DXFontBold
  else
  if Italic then
  FontUsed := m_D3DXFontItalic
  else
  FontUsed := m_D3DXFontNormal;

  GetTextExtentPoint32(FontUsed.GetDC, PChar(Text), length(Text)*sizeof(Char), Size);

  result := Size.cy;

  FontUsed := nil;
end;


procedure TDJXFont.Paragraph(
      x,y: integer;
      Width: integer;
      Text: string
    );
var
  curCol: DWORD;
  bold: boolean;
  italic: boolean;
  preedited: boolean;
  Pos: integer;
  Len: integer;
  LineHeight: integer;
  Line: integer;
  cStr: string;
  cTag: string;
  Txt: string;
  procedure ActivateTag;
  var
    i: integer;
  begin
    for i := 0 to high(colTags) do
    if cTag = colTags[i].Tag then
    begin
      curCol := ColTags[i].Value;
      exit;
    end;
    if cTag = '<b>' then
    begin
      bold := true;
      exit;
    end;
    if cTag = '</b>' then
    begin
      bold := false;
      exit;
    end;
    if cTag = '<i>' then
    begin
      italic := true;
      exit;
    end;
    if cTag = '</i>' then
    begin
      italic := false;
      exit;
    end;
    if cTag = '<pre>' then
    begin
      preEdited := true;
      exit;
    end;
    if cTag = '</pre>' then
    begin
      preEdited := false;
      exit;
    end;
    if cTag = '<br>' then
    begin
      inc(Line);
      Len := 0;
      exit;
    end;
  end;
  procedure PrintWord(Str: string);
  var
    swidth: integer;
    sHeight: integer;
  begin
    swidth := GetTextWidth(Str + ' ', bold, italic);
    sheight := GetTextHeight(Str + ' ', bold, italic);
    if len + swidth > width then
    begin
      inc(Line);
      Len := 0;
    end;
    Print(x + Len, y + Line * LineHeight + (LineHeight - sHeight), Str, curCol, bold, italic);
    Len := Len + swidth;
  end;
  procedure PrintNextWord;
  var
    NewTag: boolean;
  begin
    cStr := '';
    NewTag := false;
    while ((Txt[Pos] <> ' ') and (Txt[Pos] <> '<') and (Pos <= length(Txt))) do
    begin
      cStr := cStr + Txt[Pos];
      inc(Pos);
    end;
    if (Txt[Pos] = '<') then
    begin
      NewTag := true;
      cTag := '';
      while ((Txt[Pos] <> '>') and (Pos <= length(Txt))) do
      begin
        cTag := cTag + Txt[Pos];
        inc(Pos);
      end;
      cTag := lowercase(cTag + '>');
    end;
    inc(Pos);
    if length(cStr) > 0 then
    PrintWord(cStr);
    if NewTag then
    ActivateTag
    else
    if PreEdited then
    PrintWord('');
  end;
begin
  curCol := $ffffffff;
  bold := false;
  italic := false;
  cStr := '';
  Pos := 1;
  Len := 0;
  Line := 0;
  LineHeight := GetTextHeight('A', true);
  Txt:=StringReplace(Text, #$D#$A, '<br>', [rfReplaceAll]);
  while Pos <= length(Txt) do
  PrintNextWord;
end;

function TDJXFont.ParagraphFast(
      x,y: integer;
      Width,Height: integer;
      Text: string;
      Color: DWORD = $ffffffff;
      Bold: boolean = false;
      Italic: boolean = false;
      HAlign: TAlign = alLeft;
      VAlign: TAlign = alTop
    ) : Integer;
var
  FontUsed: ID3DXFont;
  TextRect: TRect;
  Format: cardinal;
begin
  if Bold and Italic then
  FontUsed := m_D3DXFontBoldItalic
  else
  if Bold then
  FontUsed := m_D3DXFontBold
  else
  if Italic then
  FontUsed := m_D3DXFontItalic
  else
  FontUsed := m_D3DXFontNormal;

  TextRect := Rect(x,y,x+Width,y+Height);

  Format := DT_WORDBREAK;
  case HAlign of
    alNone, alLeft: Format := Format or DT_LEFT;
    alRight: Format := Format or DT_RIGHT;
    alClient: Format := Format or DT_CENTER;
  end;
  case VAlign of
    alNone, alTop: Format := Format or DT_TOP;
    alBottom: Format := Format or DT_BOTTOM;
    alClient: Format := Format or DT_CENTER;
  end;

  Result := FontUsed.DrawTextA(
    nil,
    PChar(Text),
    -1,
    @TextRect,
    Format,
    color
  );

  FontUsed := nil;
end;

procedure TDJXFont.Print(
      x, y: integer;
      Text: string;
      Color: DWORD = $ffffffff;
      Bold: boolean = false;
      Italic: boolean = false
    );
var
  FontUsed: ID3DXFont;
  TextRect: TRect;
  Size: TSize;
begin
  if Bold and Italic then
  FontUsed := m_D3DXFontBoldItalic
  else
  if Bold then
  FontUsed := m_D3DXFontBold
  else
  if Italic then
  FontUsed := m_D3DXFontItalic
  else
  FontUsed := m_D3DXFontNormal;

  GetTextExtentPoint32(FontUsed.GetDC, PChar(Text), length(Text) * sizeof(Char), Size);
  TextRect := Rect(x, y, x + Size.cx, y + Size.cy);

  FontUsed.DrawTextA(
    nil,
    PChar(Text),
    -1,
    @TextRect,
    DT_LEFT or DT_NOCLIP,
    color
  );

  FontUsed := nil;
end;

procedure TDJXFont.SetFont(FontName: string; Size: integer);
begin
  if m_DanJetX = nil then exit;

  Release;

  m_Size := Size;

  D3DXCreateFont(
    TDanJetX(m_DanJetX).Device,
    Size,
    0,
    FW_NORMAL,
    1,
    false,
    DEFAULT_CHARSET,
    OUT_DEFAULT_PRECIS,
    ANTIALIASED_QUALITY,
    DEFAULT_PITCH or FF_DONTCARE,
    PChar(FontName),
    m_D3DXFontNormal
  );
  D3DXCreateFont(
    TDanJetX(m_DanJetX).Device,
    Size,
    0,
    FW_BOLD,
    1,
    false,
    DEFAULT_CHARSET,
    OUT_DEFAULT_PRECIS,
    ANTIALIASED_QUALITY,
    DEFAULT_PITCH or FF_DONTCARE,
    PChar(FontName),
    m_D3DXFontBold
  );
  D3DXCreateFont(
    TDanJetX(m_DanJetX).Device,
    Size,
    0,
    FW_NORMAL,
    1,
    true,
    DEFAULT_CHARSET,
    OUT_DEFAULT_PRECIS,
    ANTIALIASED_QUALITY,
    DEFAULT_PITCH or FF_DONTCARE,
    PChar(FontName),
    m_D3DXFontItalic
  );
  D3DXCreateFont(
    TDanJetX(m_DanJetX).Device,
    Size,
    0,
    FW_BOLD,
    1,
    true,
    DEFAULT_CHARSET,
    OUT_DEFAULT_PRECIS,
    ANTIALIASED_QUALITY,
    DEFAULT_PITCH or FF_DONTCARE,
    PChar(FontName),
    m_D3DXFontBoldItalic
  );
end;

procedure TDJXFont.Release;
begin
  if m_D3DXFontNormal <> nil then
  m_D3DXFontNormal := nil;
  if m_D3DXFontBold <> nil then
  m_D3DXFontBold := nil;
  if m_D3DXFontItalic <> nil then
  m_D3DXFontItalic := nil;
  if m_D3DXFontBoldItalic <> nil then
  m_D3DXFontBoldItalic := nil;
end;

constructor TDJXFont.Create(DanJetX: Pointer);
begin
  inherited Create;
  m_DanJetX := DanJetX;
end;
destructor TDJXFont.Destroy;
begin
  Release;
  inherited Destroy;
end;
//DJXFont END

end.
