Chip 2003 November/Chip_2003-11_cd1.bin/program/delphi/kompon/DIHtmlLabel.exe/Source/DIHtmlRenderer.pas

Pascal/Delphi Source File | 2003-08-27 | 65.6 KB | 2,168 lines

unit DIHtmlRenderer;

{$I DI.inc}

interface

uses
  Windows, Graphics,

  DIContainers,
  DIObjectVector,
  DIHtmlParser,
  DIHtmlCharSetPlugin,
  DIHtmlMisc;

type

  { ----------------------------------------------------------------------------
    The Node Tree

    Object hierarchy:

    TNode
    |  TParentNode
    |  |  TAreaNode
    |  |  |  TStyleNode
    |  |  |  TLinkNode
    |  |  |  TDynamicNode
    |  |  |  TRootNode
    |  TStringNode
    |  TActionNode
  ---------------------------------------------------------------------------- }

    { }
  TNodeClass = class of TNode;

  { }
  TNodeType = (ntNode, ntParentNode, ntAreaNode, ntFontNode, ntStyleNode, ntLinkNode,
    ntDynamicNode, ntRootNode, ntStringNode, ntActionNode);

  TParentNode = class;

  { ---------------------------------------------------------------------------- }

  { }
  TNode = class(TObject)
  private
    FParent: TParentNode;
  public
    function GetNodeType: TNodeType; virtual;
    property Parent: TParentNode read FParent write FParent;
  end;

  { }
  PNode = ^TNode;

  { ---------------------------------------------------------------------------- }

  { }
  TNodeList = class(TDIObjectVector)
  private
    function Get(const Index: Integer): TNode;
    procedure Put(const Index: Integer; const Value: TNode);
  public
    function Add(const Item: TNode): Integer;
    procedure Insert(const Index: Integer; const Item: TNode);
    function IndexOf(const Item: TNode): Integer;
    property Items[const Index: Integer]: TNode read Get write Put; default;
  end;

  { ---------------------------------------------------------------------------- }

  { }
  TTopLevelNodeEnumerator = class
  private
    FRootNode: TParentNode;
    FNodeClass: TNodeClass;

    FCurrentRoot: TParentNode;
    FCurrentIndex: Integer;

    FStack: TDIList;
    FRoot: TParentNode;
    procedure SetRootNode(const ARootNode: TParentNode);
  public
    destructor Destroy; override;
    function NextNode: TNode;
    property NodeClass: TNodeClass read FNodeClass write FNodeClass;
    procedure Reset;
    property RootNode: TParentNode read FRoot write SetRootNode;
  end;

  { ---------------------------------------------------------------------------- }

  { }
  TParentNode = class(TNode)
  private
    FChildren: TNodeList;
  public
    constructor Create;
    destructor Destroy; override;
    procedure AddChild(const Node: TNode);
    procedure DestroyChildren;
    function GetNodeType: TNodeType; override;
    function IndexOfChild(const Node: TNode): Integer;
    function GetFirstNodeOfClass(const NodeClass: TNodeClass): TNode;
    property Children: TNodeList read FChildren;
  end;

  { ---------------------------------------------------------------------------- }

  { }
function NewNodeList: TNodeList;
{ }
function NewNodeOwnerList: TNodeList;

{ ---------------------------------------------------------------------------- }

type
  { }
  TAreaNode = class(TParentNode)
  private
    FStartingPoint: TPoint;
    FStyles: TFontStyles;
    FColor: TColor;
    function GetText: WideString;
  protected
    function GetStyles: TFontStyles; virtual;
    function GetColor: TColor; virtual;
  public
    constructor Create;
    function GetNodeType: TNodeType; override;
    function IsPointInNode(const p: TPoint): Boolean;
    function IsPointInNodeClass(const p: TPoint; const ANodeClass: TNodeClass): Boolean; virtual;
    function GetNodeAtPointOfClass(const p: TPoint; const NodeClass: TNodeClass): TNode;
    property StartingPoint: TPoint read FStartingPoint write FStartingPoint;
    property Styles: TFontStyles read GetStyles write FStyles;
    property Color: TColor read GetColor write FColor;
    property Text: WideString read GetText;
  end;

  { ---------------------------------------------------------------------------- }
  { TFontNode
  { ---------------------------------------------------------------------------- }

  { }
  TFontNode = class(TAreaNode)
  public
    function GetNodeType: TNodeType; override;
  end;

  { ---------------------------------------------------------------------------- }
  { TStyleNode
  { ---------------------------------------------------------------------------- }

  { }
  TStyleNode = class(TAreaNode)
  private
    FStyle: TFontStyle;
  public
    constructor Create(const Style: TFontStyle);
    function GetNodeType: TNodeType; override;
    property Style: TFontStyle read FStyle write FStyle;
  end;

  { ---------------------------------------------------------------------------- }

  { }
  TLinkState = (lsNormal, lsClicked, lsHot);

  { }
  TLinkNode = class(TAreaNode)
  private
    FState: TLinkState;
    FHref: WideString;
  protected
    function GetColor: TColor; override;
  public
    constructor Create(const AHref: WideString);
    function GetNodeType: TNodeType; override;
    property State: TLinkState read FState write FState;
    property Href: WideString read FHref;
  end;

  { ---------------------------------------------------------------------------- }

  { }
  TDynamicNode = class(TAreaNode)
  private
    FID: WideString;
  public
    constructor Create(const AID: WideString);
    function GetNodeType: TNodeType; override;
    property ID: WideString read FID;
  end;

  { ---------------------------------------------------------------------------- }
  { TRectVector
  { ---------------------------------------------------------------------------- }

  { }
  TRectVector = class(TDIVector)
  public
    procedure InsertRectLast(const ARect: TRect);
  end;

  { ---------------------------------------------------------------------------- }
  { TRootNode
  { ---------------------------------------------------------------------------- }

  { }
  TRootNode = class(TAreaNode)
  private
    FRectArray: TRectVector;
  public
    constructor Create;
    destructor Destroy; override;
    function GetNodeType: TNodeType; override;
    procedure RetrieveRectsOfTLinkNodeChildren;
    function IsPointInNodeClass(const p: TPoint; const NodeClass: TNodeClass): Boolean; override;
  end;

  { ---------------------------------------------------------------------------- }

  { }
  TSpaceInfo = packed record
    LastWordEndsWithSpace: Boolean;
    SpaceWidth: Integer;
  end;

  { ---------------------------------------------------------------------------- }

  { }
  TWordInfo = packed record
    SpaceInfo: TSpaceInfo;
    Width: Integer;
  end;
  { }
  PWordInfo = ^TWordInfo;

  { ---------------------------------------------------------------------------- }

  { }
  TStringNode = class(TNode)
  private
    FText: WideString;
    FRectArray: TRectVector;
    FWordInfoArray: TDIVector;
    FFirstWordWidthRetrieved: Boolean;
  protected
  public
    constructor Create(const aText: WideString);
    destructor Destroy; override;
    procedure AddWordInfo(const SpaceInfo: TSpaceInfo; const Width: Integer);
    procedure ClearWordInfo;
    function GetNodeType: TNodeType; override;
    function GetWordInfo(const Index: Integer): TWordInfo;
    function IsPointInNode(const p: TPoint): Boolean;
    property Text: WideString read FText write FText;
    property RectArray: TRectVector read FRectArray;
    property FirstWordWidthRetrieved: Boolean read FFirstWordWidthRetrieved write FFirstWordWidthRetrieved;
    property WordInfos: TDIVector read FWordInfoArray;
  end;

  { ---------------------------------------------------------------------------- }

  { }
  TActionType = (atLineBreak, atParagraphBreak);

  { }
  TActionNode = class(TNode)
  private
    FAction: TActionType;
  public
    constructor Create(const Action: TActionType);
    function GetNodeType: TNodeType; override;
    property Action: TActionType read FAction write FAction;
  end;

  { ---------------------------------------------------------------------------- }

  { }
  TNodeTree = class(TObject)
  private
    FRoot: TRootNode;
  public
    constructor Create;
    destructor Destroy; override;
    function GetDynamicTagText(const DynamicTagID: WideString): WideString;
    function GetNodeAtPointOfClass(const p: TPoint; NodeClass: TNodeClass): TNode;
    function IsPointInTree(const p: TPoint): Boolean;
    function IsPointInNodeClass(const p: TPoint; NodeClass: TNodeClass): Boolean;
    procedure Clear;
    procedure ClearWordInfos;
    property Root: TRootNode read FRoot;
  end;

const
  { }
  clNormalLink = TColor($400 or $80000000);
  { }
  clClickedLink = TColor($401 or $80000000);
  { }
  clHotLink = TColor($402 or $80000000);

type
  { ---------------------------------------------------------------------------- }
  { TNodeObserverList
  { ---------------------------------------------------------------------------- }

  { }
  PNodeObserver = ^TNodeObserver;
  TNodeObserver = record
    ParentNode: TAreaNode;
    FirstStringNode: TStringNode;
  end;

  { ---------------------------------------------------------------------------- }

  { }
  TNodeObserverList = class(TDIVector)
  private
    function GetObserver(const Index: Integer): PNodeObserver;
    procedure SetObserver(const Index: Integer; const Value: PNodeObserver);
  public
    procedure AddObserver(const AParentNode: TAreaNode; const AFirstStringNode: TStringNode);
    function IndexOfStringNode(const Node: TStringNode): Integer;
    property Observers[const Index: Integer]: PNodeObserver read GetObserver write SetObserver; default;
  end;

function NewNodeObserverList: TNodeObserverList;

{ ---------------------------------------------------------------------------- }

type
  { }
  TElementVector = class;

  { ---------------------------------------------------------------------------- }

  { }
  TTextHandler = class(TObject)
  private
    FPosX: Integer;
    FPosY: Integer;
    FOffsetY: Integer;
    FElementVector: TElementVector;
    FRect: TRect;
    FCanvas: TCanvas;
    FLineHeight: Integer;
    FObservers: TNodeObserverList;
  public
    constructor Create(const Canvas: TCanvas; const Rect: TRect; const InitialX, InitialY, OffsetY: Integer);
    destructor Destroy; override;
    procedure TextOut(const Node: TStringNode; const Style: TFontStyles; const Color: TColor);
    procedure DoParagraphBreak;
    procedure DoLineBreak;
    procedure EmptyBuffer;
    function GetTextHeight: Integer;
    function IsPosCurrent: Boolean;
    procedure AddStartingPosObserver(const Node: TAreaNode);
    property PosX: Integer read FPosX;
    property PosY: Integer read FPosY;
  end;

  { ---------------------------------------------------------------------------- }
  { TParentTextElement
  { ---------------------------------------------------------------------------- }

  { }
  TParentTextElement = class
  end;
  { }
  PParentTextElement = ^TParentTextElement;

  { ---------------------------------------------------------------------------- }
  { TStringElement
  { ---------------------------------------------------------------------------- }

  { }
  TStringElement = class(TParentTextElement)
  private
    FNode: TStringNode;
    FStyle: TFontStyles;
    FColor: TColor;
  public
    constructor Create(const Node: TStringNode; const Style: TFontStyles; const Color: TColor);
    function BeginsWithSpace: Boolean;
    function EndsWithSpace: Boolean;
    property Node: TStringNode read FNode;
    property Style: TFontStyles read FStyle;
    property Color: TColor read FColor;
  end;

  { ---------------------------------------------------------------------------- }
  { TActionElement
  { ---------------------------------------------------------------------------- }

  { }
  TActionElement = class(TParentTextElement)
  private
    FActionType: TActionType;
  public
    constructor Create(const ActionType: TActionType);
    property ActionType: TActionType read FActionType;
  end;

  { ---------------------------------------------------------------------------- }
  { TElementVector
  { ---------------------------------------------------------------------------- }

  { }
  TElementVector = class(TDIVector)
  private
    function GetElement(const Index: Integer): TParentTextElement;
  public
    procedure AddStringElement(const Node: TStringNode; const Style: TFontStyles; const Color: TColor);
    procedure AddParagraphBreak;
    procedure AddLineBreak;
    property Items[const Index: Integer]: TParentTextElement read GetElement; default;
  end;

function NewElementVector: TElementVector;

type

  { ---------------------------------------------------------------------------- }
  { IDynamicNodeHandler
  { ---------------------------------------------------------------------------- }

    { }
  IDynamicNodeHandler = interface
    procedure HandleDynamicNode(const Node: TDynamicNode; out Source: AnsiString);
  end;

  { ---------------------------------------------------------------------------- }
  { TDefaultParser
  { ---------------------------------------------------------------------------- }

  { }
  TDefaultParser = class
  private
    FDynamicNodeHandler: IDynamicNodeHandler;
    procedure ParseNode(const HtmlParser: TDIHtmlParser; const Node: TParentNode; var FirstTextInLine: Boolean);
  protected
    procedure HandleDynamicTag(const Node: TDynamicNode);
  public
    function Parse(const Text: AnsiString): TNodeTree; overload;
    procedure AddSourceTreeToDynamicNode(const Node: TDynamicNode; const Source: AnsiString);
    property DynamicNodeHandler: IDynamicNodeHandler read FDynamicNodeHandler write FDynamicNodeHandler;
  end;

  { ---------------------------------------------------------------------------- }
  { TDIHtmlRenderer
  { ---------------------------------------------------------------------------- }

type
  { }
  TDIHtmlRenderer = class(TObject)
  private
    FLinkColor: TColor;
    FLinkColorClicked: TColor;
    FLinkColorHot: TColor;
    FLinkStyle: TFontStyles;
    FTextHandler: TTextHandler;
    FTextHeight: Integer;
    FTextOffsetY: Integer;
  protected
    procedure DoRenderNode(const Node: TAreaNode; const Styles: TFontStyles; const Color: TColor); virtual;
    function TranslateColor(const Color: TColor): TColor;
  public
    procedure RenderTree(const Canvas: TCanvas; Rect: TRect; const Tree: TNodeTree);
    procedure RenderNode(const Canvas: TCanvas; const Rect: TRect; const Node: TAreaNode);
    property TextHeight: Integer read FTextHeight;
    property LinkColor: TColor read FLinkColor write FLinkColor;
    property LinkColorClicked: TColor read FLinkColorClicked write FLinkColorClicked;
    property LinkColorHot: TColor read FLinkColorHot write FLinkColorHot;
    property LinkStyle: TFontStyles read FLinkStyle write FLinkStyle;
    property TextOffsetY: Integer read FTextOffsetY write FTextOffsetY;
  end;

const
  TAG_DYNAMIC = 'DYNAMIC';
  TAG_DYNAMIC_ID = MAX_TAG_ID + 1313;

implementation

uses
  SysUtils,
  Classes,

  DIObjectItemHandler,
  DIObjectOwnerItemHandler,
  DIHtmlColors,
  DIUtils;

{ ---------------------------------------------------------------------------- }
{ TDefaultParser
{ ---------------------------------------------------------------------------- }

procedure TDefaultParser.AddSourceTreeToDynamicNode(const Node: TDynamicNode; const Source: AnsiString);
var
  HtmlParser: TDIHtmlParser;
  HtmlCharSetPlugin: TDIHtmlCharSetPlugin;
  FirstTextInLine: Boolean;
begin
  HtmlParser := TDIHtmlParser.Create{$IFNDEF DI_No_Unicode_Component}(nil){$ENDIF};
  HtmlCharSetPlugin := TDIHtmlCharSetPlugin.Create{$IFNDEF DI_No_Unicode_Component}(nil){$ENDIF};
  try
    HtmlParser.NormalizeWhiteSpace := True;
    HtmlParser.FilterHtmlTags.SetStartEnd(fiShow);
    HtmlParser.FilterText := fiShow;
    HtmlParser.SourceBufferAsStrA := Source;

    HtmlCharSetPlugin.HtmlParser := HtmlParser;
    Node.DestroyChildren;
    FirstTextInLine := False; // No guarantee it's the first line
    ParseNode(HtmlParser, Node, FirstTextInLine);
  finally
    HtmlCharSetPlugin.Free;
    HtmlParser.Free;
  end;
end;

{ ---------------------------------------------------------------------------- }

procedure TDefaultParser.HandleDynamicTag(const Node: TDynamicNode);
var
  Source: AnsiString;
begin
  if Assigned(FDynamicNodeHandler) then
    begin
      FDynamicNodeHandler.HandleDynamicNode(Node, Source);
      if Pointer(Source) <> nil then AddSourceTreeToDynamicNode(Node, Source);
    end;
end;

{ ---------------------------------------------------------------------------- }

function TDefaultParser.Parse(const Text: AnsiString): TNodeTree;
var
  HtmlParser: TDIHtmlParser;
  HtmlCharSetPlugin: TDIHtmlCharSetPlugin;
  FirstTextInLine: Boolean;
begin
  Result := TNodeTree.Create;

  HtmlParser := TDIHtmlParser.Create{$IFNDEF DI_No_Unicode_Component}(nil){$ENDIF};
  HtmlCharSetPlugin := TDIHtmlCharSetPlugin.Create{$IFNDEF DI_No_Unicode_Component}(nil){$ENDIF};
  try
    HtmlParser.NormalizeWhiteSpace := True;
    HtmlParser.FilterHtmlTags.SetStartEnd(fiShow);
    HtmlParser.FilterText := fiShow;
    HtmlParser.SourceBufferAsStrA := Text;

    HtmlCharSetPlugin.HtmlParser := HtmlParser;
    FirstTextInLine := True;
    ParseNode(HtmlParser, Result.Root, FirstTextInLine);
  finally
    HtmlCharSetPlugin.Free;
    HtmlParser.Free;
  end;
end;

{ ---------------------------------------------------------------------------- }

procedure TDefaultParser.ParseNode(const HtmlParser: TDIHtmlParser; const Node: TParentNode; var FirstTextInLine: Boolean);
var
  NewNode: TNode;
  w: WideString;
begin
  while HtmlParser.ParseNextPiece do
    begin
      NewNode := nil;

      case HtmlParser.PieceType of

        ptHtmlTag:
          case HtmlParser.HtmlTag.TagType of

            ttStartTag:
              case HtmlParser.HtmlTag.TagID of

                TAG_A_ID:
                  NewNode := TLinkNode.Create(HtmlParser.HtmlTag.ValueOfNumber[ATTRIB_HREF_ID, 0]);

                TAG_B_ID:
                  NewNode := TStyleNode.Create(fsBold);

                TAG_BR_ID:
                  begin
                    NewNode := TActionNode.Create(atLineBreak);
                    FirstTextInLine := True;
                  end;

                TAG_DYNAMIC_ID:
                  begin
                    NewNode := TDynamicNode.Create(HtmlParser.HtmlTag.ValueOfNumber[ATTRIB_HREF_ID, 0]);
                    HandleDynamicTag(NewNode as TDynamicNode);
                  end;

                TAG_FONT_ID:
                  begin
                    w := HtmlParser.HtmlTag.ValueOfNumber[ATTRIB_COLOR_ID, 0];
                    if Pointer(w) <> nil then
                      begin
                        NewNode := TFontNode.Create;
                        TFontNode(NewNode).Color := ColorFromHtml(w);
                      end
                    else
                      Continue;
                  end;

                TAG_I_ID:
                  NewNode := TStyleNode.Create(fsItalic);

                TAG_P_ID:
                  begin
                    NewNode := TActionNode.Create(atParagraphBreak);
                    FirstTextInLine := True;
                  end;

                TAG_S_ID:
                  NewNode := TStyleNode.Create(fsStrikeOut);

                TAG_U_ID:
                  NewNode := TStyleNode.Create(fsUnderline);

              else
                Continue;
              end;

            ttEndTag:
              begin
                case HtmlParser.HtmlTag.TagID of

                  TAG_A_ID:
                    if Node is TLinkNode then
                      Break;

                  TAG_B_ID:
                    if (Node is TStyleNode) and (TStyleNode(Node).Style = fsBold) then
                      Break;

                  TAG_FONT_ID:
                    if Node is TFontNode then
                      Break;

                  TAG_I_ID:
                    if (Node is TStyleNode) and (TStyleNode(Node).Style = fsItalic) then
                      Break;

                  TAG_S_ID:
                    if (Node is TStyleNode) and (TStyleNode(Node).Style = fsStrikeOut) then
                      Break;

                  TAG_U_ID:
                    if (Node is TStyleNode) and (TStyleNode(Node).Style = fsUnderline) then
                      Break;

                end;
                { Ignore all unknown closing tags and continue the parsing
                  at this node level. }
                Continue;
              end;

          end;

        ptText:
          if not FirstTextInLine then
            begin
              NewNode := TStringNode.Create(HtmlParser.DataAsStrW);
            end
          else
            begin
              NewNode := TStringNode.Create(HtmlParser.DataAsStrTrimLeftW);
              FirstTextInLine := False;
            end;

      else
        Continue;
      end;

      if NewNode <> nil then
        begin
          Node.AddChild(NewNode);
          { Returns whether the given node can contain other elements and thus
            descends from TParentNode. Descendants from this class begin with <?> and
            end with </?> (for example, <B> and </B>). Nodes that descend from
            TActionNode shouldn't be terminated with </?> (for example, <P>). Note
            that TDynamicNode is special; while it descends from TParentNode, it never
            contains children at parse-time, thus we shouldn't wait for a redundant
            </DYNAMIC>. Instead, its contents are supplied before it's rendered by
            compiled program code. }
          if (HtmlParser.HtmlTag.TagType = ttStartTag) and
            (NewNode is TParentNode) and
            not (NewNode is TDynamicNode) then
            ParseNode(HtmlParser, TParentNode(NewNode), firsttextinline);
        end;
    end;
end;

{ ---------------------------------------------------------------------------- }
{ TRectVector
{ ---------------------------------------------------------------------------- }

var
  RectItemHandler: TDIItemHandler = nil;

function GetRectItemHandler: TDIItemHandler;
begin
  if RectItemHandler = nil then
    begin
      RectItemHandler := TDIItemHandler.Create;
      RectItemHandler.ItemSize := SizeOf(TRect);
    end;
  Result := RectItemHandler;
end;

{ ---------------------------------------------------------------------------- }

function NewRectVector: TRectVector;
begin
  Result := TRectVector.Create(GetRectItemHandler);
end;

{ ---------------------------------------------------------------------------- }

function SamePointInRectFunc(const Sender: TDIContainer; const PItem1, PItem2, Extra: Pointer): Boolean;
begin
  Result := PtInRect(PRect(PItem1)^, PPoint(PItem2)^);
end;

{ ---------------------------------------------------------------------------- }

procedure TRectVector.InsertRectLast(const ARect: TRect);
begin
  with PRect(InsertItemLast)^ do
    begin
      Left := ARect.Left;
      Top := ARect.Top;
      Right := ARect.Right;
      Bottom := ARect.Bottom;
    end;
end;

{ ---------------------------------------------------------------------------- }
{ TNodeTree
{ ---------------------------------------------------------------------------- }

constructor TNodeTree.Create;
begin
  inherited;
  FRoot := TRootNode.Create;
  FRoot.Color := clWindowText;
end;

{ ---------------------------------------------------------------------------- }

destructor TNodeTree.Destroy;
begin
  Clear;
  FRoot.Free;
  inherited;
end;

{ ---------------------------------------------------------------------------- }

procedure TNodeTree.Clear;
begin
  FRoot.DestroyChildren;
  inherited;
end;

{ ---------------------------------------------------------------------------- }

procedure TNodeTree.ClearWordInfos;
var
  NodeEnum: TTopLevelNodeEnumerator;
  StringNode: TStringNode;
begin
  NodeEnum := TTopLevelNodeEnumerator.Create;
  NodeEnum.RootNode := FRoot;
  NodeEnum.NodeClass := TStringNode;

  StringNode := TStringNode(NodeEnum.NextNode);
  while StringNode <> nil do
    begin
      StringNode.ClearWordInfo;
      StringNode := TStringNode(NodeEnum.NextNode);
    end;
  NodeEnum.Free;
end;

{ ---------------------------------------------------------------------------- }

function TNodeTree.GetNodeAtPointOfClass(const p: TPoint; NodeClass: TNodeClass): TNode;
begin
  Result := FRoot.GetNodeAtPointOfClass(p, NodeClass);
end;

{ ---------------------------------------------------------------------------- }

function TNodeTree.IsPointInNodeClass(const p: TPoint; NodeClass: TNodeClass): Boolean;
begin
  Result := FRoot.IsPointInNodeClass(p, NodeClass);
end;

{ ---------------------------------------------------------------------------- }

function TNodeTree.IsPointInTree(const p: TPoint): Boolean;
begin
  Result := FRoot.IsPointInNode(p);
end;

{ ---------------------------------------------------------------------------- }
{ TParentNode
{ ---------------------------------------------------------------------------- }

constructor TParentNode.Create;
begin
  inherited;
  FChildren := NewNodeOwnerList;
end;

{ ---------------------------------------------------------------------------- }

destructor TParentNode.Destroy;
begin
  FChildren.Free;
  inherited;
end;

{ ---------------------------------------------------------------------------- }

procedure TParentNode.AddChild(const Node: TNode);
begin
  FChildren.InsertObjectLast(Node);
  Node.Parent := Self;
end;

{ ---------------------------------------------------------------------------- }

procedure TParentNode.DestroyChildren;
begin
  FChildren.Clear;
end;

{ ---------------------------------------------------------------------------- }

function TParentNode.GetFirstNodeOfClass(const NodeClass: TNodeClass): TNode;

  function RecurseTree(const CurrentRoot: TParentNode): TNode;
  var
    i: Integer;
  begin
    Result := nil;
    for i := 0 to CurrentRoot.Children.Count - 1 do
      if CurrentRoot.Children[i] is NodeClass then
        begin
          Result := CurrentRoot.FChildren[i];
          Exit;
        end
      else
        if CurrentRoot.Children[i] is TParentNode then
          Result := RecurseTree(TParentNode(CurrentRoot.Children[i]));
  end;

begin
  Result := RecurseTree(Self);
end;

{ ---------------------------------------------------------------------------- }

function TParentNode.GetNodeType: TNodeType;
begin
  Result := ntParentNode;
end;

{ ---------------------------------------------------------------------------- }

function TParentNode.IndexOfChild(const Node: TNode): Integer;
begin
  Result := FChildren.IndexOf(Node);
end;

{ ---------------------------------------------------------------------------- }
{ TNodeList
{ ---------------------------------------------------------------------------- }

function NewNodeList: TNodeList;
begin
  Result := TNodeList.Create(GetDIObjectItemHandler);
end;

{ ---------------------------------------------------------------------------- }

function NewNodeOwnerList: TNodeList;
begin
  Result := TNodeList.Create(GetDIObjectOwnerItemHandler);
end;

{ ---------------------------------------------------------------------------- }

function TNodeList.Add(const Item: TNode): Integer;
begin
  Result := Count;
  InsertObjectLast(Item);
end;

{ ---------------------------------------------------------------------------- }

function TNodeList.Get(const Index: Integer): TNode;
begin
  Result := TNode(ObjectAt[Index]);
end;

{ ---------------------------------------------------------------------------- }

function TNodeList.IndexOf(const Item: TNode): Integer;
begin
  Result := IndexOfObject(Item);
end;

{ ---------------------------------------------------------------------------- }

procedure TNodeList.Insert(const Index: Integer; const Item: TNode);
begin
  InsertObjectAt(Index, Item);
end;

{ ---------------------------------------------------------------------------- }

procedure TNodeList.Put(const Index: Integer; const Value: TNode);
begin
  ObjectAt[Index] := Value;
end;

{ ---------------------------------------------------------------------------- }
{ TStringNode
{ ---------------------------------------------------------------------------- }

var
  WordInfoItemHandler: TDIItemHandler = nil;

function GetWordInfoItemHandler: TDIItemHandler;
begin
  Result := WordInfoItemHandler;
  if Result = nil then
    begin
      WordInfoItemHandler := TDIItemHandler.Create;
      with WordInfoItemHandler do
        begin
          ItemSize := SizeOf(TWordInfo);
        end;
      Result := WordInfoItemHandler;
    end;
end;

{ ---------------------------------------------------------------------------- }

constructor TStringNode.Create(const aText: WideString);
begin
  inherited Create;
  FWordInfoArray := TDIVector.Create(GetWordInfoItemHandler);
  FRectArray := NewRectVector;
  FText := aText;
end;

{ ---------------------------------------------------------------------------- }

destructor TStringNode.Destroy;
begin
  FRectArray.Free;
  FWordInfoArray.Free;
  inherited;
end;

{ ---------------------------------------------------------------------------- }

procedure TStringNode.AddWordInfo(const SpaceInfo: TSpaceInfo; const Width: Integer);
var
  WordInfo: PWordInfo;
begin
  WordInfo := FWordInfoArray.InsertItemLast;
  WordInfo^.SpaceInfo := SpaceInfo;
  WordInfo^.Width := Width;
end;

{ ---------------------------------------------------------------------------- }

procedure TStringNode.ClearWordInfo;
begin
  FWordInfoArray.Clear;
end;

{ ---------------------------------------------------------------------------- }

function TStringNode.GetNodeType: TNodeType;
begin
  Result := ntStringNode;
end;

{ ---------------------------------------------------------------------------- }

function TStringNode.GetWordInfo(const Index: Integer): TWordInfo;
begin
  Result := PWordInfo(FWordInfoArray.PItemAt[Index])^;
end;

{ ---------------------------------------------------------------------------- }

function TStringNode.IsPointInNode(const p: TPoint): Boolean;
begin
  Result := FRectArray.Exists(@p, SamePointInRectFunc);
end;

{ ---------------------------------------------------------------------------- }
{ TStyleNode
{ ---------------------------------------------------------------------------- }

constructor TStyleNode.Create(const Style: TFontStyle);
begin
  inherited Create;
  FStyle := Style;
end;

{ ---------------------------------------------------------------------------- }

function TStyleNode.GetNodeType: TNodeType;
begin
  Result := ntStyleNode;
end;

{ ---------------------------------------------------------------------------- }
{ TActionNode
{ ---------------------------------------------------------------------------- }

constructor TActionNode.Create(const Action: TActionType);
begin
  inherited Create;
  FAction := Action;
end;

{ ---------------------------------------------------------------------------- }

function TActionNode.GetNodeType: TNodeType;
begin
  Result := ntActionNode;
end;

{ ---------------------------------------------------------------------------- }
{ TAreaNode
{ ---------------------------------------------------------------------------- }

constructor TAreaNode.Create;
var
  Zero: Integer;
begin
  inherited;
  Zero := 0;
  with FStartingPoint do
    begin
      x := Zero;
      y := Zero;
    end;
end;

{ ---------------------------------------------------------------------------- }

function TAreaNode.GetColor: TColor;
begin
  Result := FColor;
end;

{ ---------------------------------------------------------------------------- }

function TAreaNode.GetNodeAtPointOfClass(const p: TPoint; const NodeClass: TNodeClass): TNode;
var
  NodeEnum: TTopLevelNodeEnumerator;
begin
  NodeEnum := TTopLevelNodeEnumerator.Create;
  NodeEnum.RootNode := Self;
  NodeEnum.NodeClass := TAreaNode;
  Result := NodeEnum.NextNode;
  while Result <> nil do
    begin
      if TAreaNode(Result).IsPointInNode(p) then
        if Result is NodeClass then
          Break
        else
          begin
            Result := TAreaNode(Result).GetNodeAtPointOfClass(p, NodeClass);
            if Result <> nil then Break;
          end;
      Result := NodeEnum.NextNode;
    end;
  NodeEnum.Free;
end;

{ ---------------------------------------------------------------------------- }

function TAreaNode.GetNodeType: TNodeType;
begin
  Result := ntAreaNode;
end;

{ ---------------------------------------------------------------------------- }

function TAreaNode.GetStyles: TFontStyles;
begin
  Result := FStyles;
end;

{ ---------------------------------------------------------------------------- }

function TAreaNode.GetText: WideString;
var
  NodeEnum: TTopLevelNodeEnumerator;
  Node: TStringNode;
begin
  Result := '';
  NodeEnum := TTopLevelNodeEnumerator.Create;
  NodeEnum.RootNode := Self;
  NodeEnum.NodeClass := TStringNode;
  Node := TStringNode(NodeEnum.NextNode);
  while Node <> nil do
    begin
      Result := Result + Node.Text;
      Node := TStringNode(NodeEnum.NextNode);
    end;
  NodeEnum.Free;
end;

{ ---------------------------------------------------------------------------- }

function TAreaNode.IsPointInNode(const p: TPoint): Boolean;
var
  NodeEnum: TTopLevelNodeEnumerator;
  Node: TStringNode;
begin
  NodeEnum := TTopLevelNodeEnumerator.Create;
  NodeEnum.RootNode := Self;
  NodeEnum.NodeClass := TStringNode;
  Node := TStringNode(NodeEnum.NextNode);
  while (Node <> nil) and not Node.IsPointInNode(p) do
    Node := TStringNode(NodeEnum.NextNode);
  NodeEnum.Free;
  Result := Node <> nil;
end;

{ ---------------------------------------------------------------------------- }

function TAreaNode.IsPointInNodeClass(const p: TPoint; const ANodeClass: TNodeClass): Boolean;
var
  NodeEnum: TTopLevelNodeEnumerator;
  Node: TNode;
begin
  Result := False;
  NodeEnum := TTopLevelNodeEnumerator.Create;
  NodeEnum.RootNode := Self;
  NodeEnum.NodeClass := ANodeClass;

  Node := NodeEnum.NextNode;
  while Node <> nil do
    begin
      if Node is TAreaNode then
        begin
          Result := TAreaNode(Node).IsPointInNode(p);
          if Result then Break;
        end;
      Node := NodeEnum.NextNode;
    end;
  NodeEnum.Free;
end;

{ ---------------------------------------------------------------------------- }
{ TNode
{ ---------------------------------------------------------------------------- }

function TNode.GetNodeType: TNodeType;
begin
  { We get the dynamic type using TObject.ClassType, which returns a pointer to
    the class' virtual memory table, instead of testing using the "is" reserved
    word. We do this as any node is a TNode (thanks to polymorphism); we would
    have to test in reverse order, as if we tested for TNode first everything
    would appear to be a TNode. This could get messy when we add more TNode
    descendants later. }
  Result := ntNode;
end;

{ ---------------------------------------------------------------------------- }
{ TTopLevelNodeEnumerator
{ ---------------------------------------------------------------------------- }

var
  NodeStackItemHandler: TDIItemHandler = nil;

type
  TNodeStackItem = packed record
    Node: TParentNode;
    Index: Integer;
  end;
  PNodeStackItem = ^TNodeStackItem;

function GetNodeStackItemHandler: TDIItemHandler;
begin
  if NodeStackItemHandler = nil then
    begin
      NodeStackItemHandler := TDIItemHandler.Create;
      NodeStackItemHandler.ItemSize := SizeOf(TNodeStackItem);
    end;
  Result := NodeStackItemHandler;
end;

{ ---------------------------------------------------------------------------- }

destructor TTopLevelNodeEnumerator.Destroy;
begin
  FStack.Free;
  inherited;
end;

{ ---------------------------------------------------------------------------- }

function TTopLevelNodeEnumerator.NextNode: TNode;
label
  Start;
var
  NodeStackItem: PNodeStackItem;
begin
  Start:
  if FCurrentIndex < FCurrentRoot.Children.Count then
    begin
      Result := FCurrentRoot.Children[FCurrentIndex];
      Inc(FCurrentIndex);
      { If we find a child that is of the requested type, return it. Do not add
        it to the stack, as we're not interested in this node's children.
        After all, we are a top level enumerator! }
      if Result is FNodeClass then
        Exit
      else
        begin
          if Result is TParentNode then
            begin
              if FStack = nil then
                FStack := TDIList.Create(GetNodeStackItemHandler);
              NodeStackItem := FStack.InsertItemLast;
              NodeStackItem^.Node := FCurrentRoot;
              NodeStackItem^.Index := FCurrentIndex;

              FCurrentRoot := TParentNode(Result);
              FCurrentIndex := 0;
            end;
          goto Start;
        end
    end
  else
    if (FStack <> nil) and (FStack.IsNotEmpty) then
      begin
        NodeStackItem := FStack.PLastItem;
        FCurrentRoot := NodeStackItem^.Node;
        FCurrentIndex := NodeStackItem^.Index;
        FStack.DeleteLast;
        goto Start;
      end;
  Result := nil;
end;

{ ---------------------------------------------------------------------------- }

procedure TTopLevelNodeEnumerator.Reset;
begin
  if FStack <> nil then
    FStack.Clear;
  FCurrentRoot := FRootNode;
  FCurrentIndex := 0;
end;

{ ---------------------------------------------------------------------------- }

procedure TTopLevelNodeEnumerator.SetRootNode(const ARootNode: TParentNode);
begin
  FRootNode := ARootNode;
  Reset;
end;

{ ---------------------------------------------------------------------------- }
{ TFontNode
{ ---------------------------------------------------------------------------- }

function TFontNode.GetNodeType: TNodeType;
begin
  Result := ntFontNode;
end;

{ ---------------------------------------------------------------------------- }
{ TLinkNode }
{ ---------------------------------------------------------------------------- }

constructor TLinkNode.Create(const AHref: WideString);
begin
  inherited Create;
  FHref := AHref;
end;

{ ---------------------------------------------------------------------------- }

function TLinkNode.GetColor: TColor;
begin
  case State of
    lsNormal:
      Result := clNormalLink;
    lsClicked:
      Result := clClickedLink;
    lsHot:
      Result := clHotLink;
  else
    Result := FColor;
  end;
end;

{ ---------------------------------------------------------------------------- }

function TLinkNode.GetNodeType: TNodeType;
begin
  Result := ntLinkNode;
end;

{ ---------------------------------------------------------------------------- }
{ TRootNode }
{ ---------------------------------------------------------------------------- }

constructor TRootNode.Create;
begin
  inherited Create;
  FRectArray := NewRectVector;
end;

{ ---------------------------------------------------------------------------- }

destructor TRootNode.Destroy;
begin
  FRectArray.Free;
  inherited;
end;

{ ---------------------------------------------------------------------------- }

function TRootNode.GetNodeType: TNodeType;
begin
  Result := ntRootNode;
end;

{ ---------------------------------------------------------------------------- }

function TRootNode.IsPointInNodeClass(const p: TPoint; const NodeClass: TNodeClass): Boolean;
begin
  { In the root, we cache the locations of all our TLinkNode children, not only
    our most immediate children but all of them, even if they have a parent
    other than the root node. We do this to improve performance, as this routine
    might be queried every time the mouse is moved. On a PII-400 MHz computer,
    TDIHtmlLabel alone might consume 20% CPU power without this optimization when
    we move the mouse pointer as fast as we can, which is not acceptable. With
    this optimization, we consume only about a third as much CPU power. }
  if NodeClass = TLinkNode then
    Result := FRectArray.Exists(@p, SamePointInRectFunc)
  else
    Result := inherited IsPointInNodeClass(p, NodeClass);
end;

{ ---------------------------------------------------------------------------- }

procedure TRootNode.RetrieveRectsOfTLinkNodeChildren;
var
  LinkNodeEnum, StringNodeEnum: TTopLevelNodeEnumerator;
  LinkNode: TLinkNode;
  StringNode: TStringNode;
  i: Integer;
begin
  FRectArray.Clear;
  LinkNodeEnum := TTopLevelNodeEnumerator.Create;
  LinkNodeEnum.RootNode := Self;
  LinkNodeEnum.NodeClass := TLinkNode;

  StringNodeEnum := TTopLevelNodeEnumerator.Create;
  StringNodeEnum.NodeClass := TStringNode;

  LinkNode := TLinkNode(LinkNodeEnum.NextNode);
  while LinkNode <> nil do
    begin
      StringNodeEnum.RootNode := LinkNode;
      StringNode := TStringNode(StringNodeEnum.NextNode);
      while StringNode <> nil do
        begin
          for i := 0 to StringNode.RectArray.Count - 1 do
            FRectArray.InsertRectLast(PRect(StringNode.RectArray.PItemAt[i])^);
          StringNode := TStringNode(StringNodeEnum.NextNode);
        end;
      LinkNode := TLinkNode(LinkNodeEnum.NextNode);
    end;

  StringNodeEnum.Free;
  LinkNodeEnum.Free;
end;

{ ---------------------------------------------------------------------------- }
{ TDynamicNode
{ ---------------------------------------------------------------------------- }

constructor TDynamicNode.Create(const AID: WideString);
begin
  inherited Create;
  FID := AID;
end;

{ ---------------------------------------------------------------------------- }

function TNodeTree.GetDynamicTagText(const DynamicTagID: WideString): WideString;
var
  NodeEnum: TTopLevelNodeEnumerator;
  Node: TDynamicNode;
begin
  NodeEnum := TTopLevelNodeEnumerator.Create;
  NodeEnum.RootNode := Root;
  NodeEnum.NodeClass := TDynamicNode;

  Node := TDynamicNode(NodeEnum.NextNode);
  while (Node <> nil) and (Node.ID <> DynamicTagID) do
    Node := TDynamicNode(NodeEnum.NextNode);
  NodeEnum.Free;

  if Node <> nil then
    Result := Node.Text
  else
    Result := '';
end;

{ ---------------------------------------------------------------------------- }

function TDynamicNode.GetNodeType: TNodeType;
begin
  Result := ntDynamicNode;
end;

{ ---------------------------------------------------------------------------- }
{ TWordEnumerator
{ ---------------------------------------------------------------------------- }

type
  TWordEnumerator = class(TObject)
  private
    FTextPtr: PWideChar;
    FTextLength: Cardinal;
    FText: WideString;
    FCount: Integer;
    procedure SetText(const aText: WideString);
    function GetNext(const IncrementPos: Boolean): WideString;
  public
    function PeekNext: WideString;
    function PopNext: WideString;
    function HasNext: Boolean;
    procedure Reset;

    property Count: Integer read FCount;
    property Text: WideString read FText write SetText;
  end;

  { ---------------------------------------------------------------------------- }
  { TElementVector
  { ---------------------------------------------------------------------------- }

function NewElementVector: TElementVector;
begin
  Result := TElementVector.Create(GetDIObjectOwnerItemHandler);
end;

{ ---------------------------------------------------------------------------- }

procedure TElementVector.AddLineBreak;
begin
  PParentTextElement(InsertItemLast)^ := TActionElement.Create(atLineBreak);
end;

{ ---------------------------------------------------------------------------- }

procedure TElementVector.AddParagraphBreak;
begin
  PParentTextElement(InsertItemLast)^ := TActionElement.Create(atParagraphBreak);
end;

{ ---------------------------------------------------------------------------- }

procedure TElementVector.AddStringElement(const Node: TStringNode; const Style: TFontStyles; const Color: TColor);
begin
  PParentTextElement(InsertItemLast)^ := TStringElement.Create(Node, Style, Color);
end;

{ ---------------------------------------------------------------------------- }

function TElementVector.GetElement(const Index: Integer): TParentTextElement;
begin
  Result := PParentTextElement(PItemAt[Index])^;
end;

{ ---------------------------------------------------------------------------- }
{ TTextHandler
{ ---------------------------------------------------------------------------- }

procedure TTextHandler.AddStartingPosObserver(const Node: TAreaNode);
begin
  FObservers.AddObserver(Node, TStringNode(Node.GetFirstNodeOfClass(TStringNode)));
end;

{ ---------------------------------------------------------------------------- }

constructor TTextHandler.Create(const Canvas: TCanvas; const Rect: TRect; const InitialX, InitialY, OffsetY: Integer);
var
  TempFontStyle: TFontStyles;
const
  MaximumHeightString = 'fg';
begin
  inherited Create;
  FCanvas := Canvas;
  FRect := Rect;
  FPosX := InitialX;
  FPosY := InitialY;
  FOffsetY := OffsetY;

  { TextHeight returns slightly different values depending on whether fsBold is
    in Canvas.Font.Style. This is not acceptable, as it's important that
    FLineHeight stays constant between TTextHandler instances. Thus we set
    Canvas.Font.Style to [] before calculating the line height. }
  TempFontStyle := Canvas.Font.Style;
  Canvas.Font.Style := [];
  FLineHeight := TextHeightW(Canvas.Handle, MaximumHeightString);
  Canvas.Font.Style := TempFontStyle;

  FElementVector := NewElementVector;
  FObservers := NewNodeObserverList;
end;

{ ---------------------------------------------------------------------------- }

destructor TTextHandler.Destroy;
begin
  FObservers.Free;
  FElementVector.Free;
  inherited;
end;

{ ---------------------------------------------------------------------------- }

procedure TTextHandler.DoLineBreak;
begin
  FElementVector.AddLineBreak;
  EmptyBuffer;
end;

{ ---------------------------------------------------------------------------- }

procedure TTextHandler.DoParagraphBreak;
begin
  FElementVector.AddParagraphBreak;
  EmptyBuffer;
end;

{ ---------------------------------------------------------------------------- }

procedure TTextHandler.EmptyBuffer;
var
  i: Integer;
  StrElement: TStringElement;
  WordEnum: TWordEnumerator;
  Buffer: WideString;
  NextWord: WideString;
  NextWordWidth: Integer;
  Width: Integer;
  SpaceInfo: TSpaceInfo;

  function GetWidth(out SpaceInfo: TSpaceInfo): Integer;
  var
    j: Integer;
    PrivateWordEnum: TWordEnumerator;
    WordElement: WideString;
    CurrentElement: TStringElement;
  begin
    { If the width of the first word has already been included in the count,
      don't count it again; thus, return 0. }
    if StrElement.Node.FirstWordWidthRetrieved and (WordEnum.Count = 1) then
      Result := 0
    else
      Result := TextWidthW(FCanvas.Handle, NextWord);

    { Update record with default information; might be overwritten later if
      we're dealing with quite special markup. }
    with SpaceInfo do
      begin
        LastWordEndsWithSpace := (Pointer(NextWord) <> nil) and (NextWord[Length(NextWord)] = WC_SPACE);
        SpaceWidth := TextWidthW(FCanvas.Handle, WC_SPACE);
      end;

    if not WordEnum.HasNext and not (StrElement.Node.FirstWordWidthRetrieved and (WordEnum.Count = 1)) then
      begin
        PrivateWordEnum := nil;

        j := i + 1;

        while (j < FElementVector.Count) and
          (FElementVector[j - 1] is TStringElement) and
          (FElementVector[j] is TStringElement) and
          (not TStringElement(FElementVector[j - 1]).EndsWithSpace) and
          (not TStringElement(FElementVector[j]).BeginsWithSpace) do // Part of the same word
          begin
            CurrentElement := TStringElement(FElementVector[j]);

            if PrivateWordEnum = nil then
              PrivateWordEnum := TWordEnumerator.Create;
            PrivateWordEnum.Text := CurrentElement.Node.Text;

            FCanvas.Font.Style := CurrentElement.Style;
            WordElement := PrivateWordEnum.PopNext;
            Inc(Result, TextWidthW(FCanvas.Handle, WordElement));
            CurrentElement.Node.FirstWordWidthRetrieved := True;

            // Update record
            if j = FElementVector.Count - 1 then
              with SpaceInfo do
                begin
                  LastWordEndsWithSpace := (Pointer(WordElement) <> nil) and (WordElement[Length(WordElement)] = WC_SPACE);
                  SpaceWidth := TextWidthW(FCanvas.Handle, WC_SPACE);
                end;

            // We're only φnterested in the first word; let's break if there are more
            if PrivateWordEnum.HasNext then
              Break;
            Inc(j);
          end;

        PrivateWordEnum.Free;

        // Restore canvas
        FCanvas.Font.Style := StrElement.Style;
      end;
  end;

  { ---------- }

  function GetWidthWithoutLastSpace: Integer;
  begin
    if SpaceInfo.LastWordEndsWithSpace then
      Result := Width - SpaceInfo.SpaceWidth
    else
      Result := Width;
  end;

  { ---------- }

  function IsFirstWordOfSource: Boolean;
  begin
    { If we are processing the first word of the source, we don't want to word
      wrap; we'd simply leave an empty line at the top. }
    Result := (FPosX = FRect.Left) and (FPosY = FRect.Top) and (WordEnum.Count = 1);
  end;

  { ---------- }

  function IsInWord: Boolean;
  begin
    Result := StrElement.Node.FirstWordWidthRetrieved and (WordEnum.Count = 1);
  end;

  { ---------- }

  procedure NotifyObservers;
  var
    Index: Integer;
  begin
    { Notify observers that we are processing the node they are interested in.
      Note that more than one observer may be interested in monitoring the same
      node; TDynamicNode is a good example. }
    Index := FObservers.IndexOfStringNode(StrElement.Node);
    while Index >= 0 do
      begin
        with FObservers[Index]^.ParentNode.StartingPoint do
          begin
            x := FPosX;
            y := FPosY;
          end;
        FObservers.DeleteAt(Index);
        Index := FObservers.IndexOfStringNode(StrElement.Node);
      end;
  end;

  { ---------- }

  function GetCurrentRect: TRect;
  begin
    Result := Rect(FPosX, FPosY + FOffsetY, FPosX + TextWidthW(FCanvas.Handle, Buffer), FPosY + +FOffsetY + FLineHeight);
  end;

var
  Element: TParentTextElement;
begin
  for i := 0 to FElementVector.Count - 1 do
    begin
      Element := FElementVector[i];

      if Element is TActionElement then
        begin
          FPosX := FRect.Left;
          case TActionElement(Element).ActionType of
            atLineBreak:
              Inc(FPosY, FLineHeight);
            atParagraphBreak:
              // Add half the line height, but at least 2 additional pixel regardless of FLineHeight.
              Inc(FPosY, FLineHeight + (FLineHeight div 2) or 2);
          end;
        end
      else
        if Element is TStringElement then
          with FCanvas do
            begin
              StrElement := TStringElement(Element);
              NotifyObservers;

              Font.Style := StrElement.Style;
              Font.Color := StrElement.Color;

              WordEnum := TWordEnumerator.Create;
              WordEnum.Text := StrElement.Node.Text;
              Buffer := '';
              Width := 0;
              StrElement.Node.RectArray.Clear;

              while WordEnum.HasNext do
                begin
                  NextWord := WordEnum.PopNext;

                  { We cache information about each individual word to speed rendering;
                    this way, we don't have to recalculate this information every time
                    this routine is called (basically every time the tree needs to be
                    repainted). We also do this as we otherwise wouldn't get correct
                    output when rendering nodes individually (for example, we frequently
                    rerender TLinkNodes with a different color). We only break after every
                    complete word, and one node might not contain complete words. GetWidth
                    makes use of information from other nodes succeeding the current one
                    if necessary; this explains why it's important to only store
                    information gathered when rendering the complete tree, that is, the
                    first time we render anything at all. }
                  if StrElement.Node.WordInfos.Count >= WordEnum.Count then
                    begin
                      NextWordWidth := StrElement.Node.GetWordInfo(WordEnum.Count - 1).Width;
                      SpaceInfo := StrElement.Node.GetWordInfo(WordEnum.Count - 1).SpaceInfo;
                    end
                  else
                    begin
                      NextWordWidth := GetWidth(SpaceInfo);
                      StrElement.Node.AddWordInfo(SpaceInfo, NextWordWidth);
                    end;

                  Inc(Width, NextWordWidth);

                  if (FPosX + GetWidthWithoutLastSpace >= FRect.Right) and
                    not (NextWord = WC_SPACE) and // Never wrap because of lone space elements
                  not IsFirstWordOfSource and // Don't wrap if we have yet to output anything
                  not IsInWord then // We can't wrap if we're in the middle of rendering a word
                    begin // Word wrap
                      { Output contents of buffer, empty it and start on a new line, thus
                        resetting FPosX and incrementing FPosY. }
                      TrimRightByRefW(Buffer);

                      { Check to draw text only if it is within out rectangle.
                        Some graphic output weired things if the painting
                         coordinates are way out of the drawing rect (> 8000 pixels). }
                      if (FPosY + FOffsetY + FLineHeight > 0) and (FPosY + FOffsetY < FRect.Bottom) then
                        ExtTextOutW(Handle, FPosX, FPosY + FOffsetY, 0, nil, Pointer(Buffer), Length(Buffer), nil);
                      StrElement.Node.RectArray.InsertRectLast(GetCurrentRect);
                      Buffer := '';
                      FPosX := FRect.Left;
                      Width := NextWordWidth;
                      Inc(FPosY, FLineHeight);
                    end
                  else
                    if StrElement.Node.FirstWordWidthRetrieved and
                      WordEnum.HasNext and
                      (WordEnum.Count = 1) then
                      Inc(Width, TextWidthW(FCanvas.Handle, NextWord));

                  Buffer := Buffer + NextWord;
                end;
              WordEnum.Free;

              if (FPosY + FOffsetY + FLineHeight > 0) and (FPosY + FOffsetY < FRect.Bottom) then
                ExtTextOutW(Handle, FPosX, FPosY + FOffsetY, 0, nil, Pointer(Buffer), Length(Buffer), nil);
              StrElement.Node.RectArray.InsertRectLast(GetCurrentRect);
              Inc(FPosX, TextWidthW(FCanvas.Handle, Buffer));
            end
        else
          raise Exception.Create('TTextHandler.EmptyBuffer: Unsupported TParentTextElement descendant encountered');

    end;
  FElementVector.Clear;
end;

{ ---------------------------------------------------------------------------- }

function TTextHandler.GetTextHeight: Integer;
begin
  Result := FPosY + FLineHeight;
end;

{ ---------------------------------------------------------------------------- }

function TTextHandler.IsPosCurrent: Boolean;
begin
  Result := FElementVector.Count = 0;
end;

{ ---------------------------------------------------------------------------- }

procedure TTextHandler.TextOut(const Node: TStringNode; const Style: TFontStyles; const Color: TColor);
{ Consider these strings:
  "This is a <B>test</B>"
    We first store the string and its attributes in our list. As it ends with
    a space character, we know it's safe to empty our buffer (thus rendering
    the results to the screen). When we encounter "test", we don't know for
    sure whether it'll be followed by a new word or a new substring ("run"?).
    We have to wait until someone tells us that we've reached the end of the
    string by calling our public EmptyBuffer method.
  "This is a<B> test</B>"
    As usual, we store the first node element ("This is a"). As it doesn't end
    with a space, it could be followed by another character. However, when we
    encounter " test", we know that it was indeed a separate word. We
    immediately call EmptyBuffer before parsing the new string.
  "<B>Te</B><I>s</I>ting stuff "
    Here's an instance of the general problem this class was designed to
    solve. We first store "Te" and its attributes, as it might only be a part
    of a word. Indeed, in this case we're right. When we get to "s", we store
    this in a second entry in the list. "ting" is then stored in a third
    entry after which we discover that the last character is a space, meaning
    that we've assembled an entire word. Thus we empty our buffer. }
var
  l: Cardinal;
begin
  l := Cardinal(Node.Text);
  if l = 0 then Exit;

  if Node.Text[1] = WC_SPACE then
    EmptyBuffer;

  FElementVector.AddStringElement(Node, Style, Color);

  if Node.Text[PCardinal(l - 4)^ div 2] = WC_SPACE then
    EmptyBuffer;
end;

{ ---------------------------------------------------------------------------- }
{ TWordEnumerator
{ ---------------------------------------------------------------------------- }

function TWordEnumerator.GetNext(const IncrementPos: Boolean): WideString;
var
  p: PWideChar;
  l: Cardinal;
begin
  l := FTextLength;
  if l > 0 then
    begin
      p := FTextPtr;

      repeat
        if p^ = WC_SPACE then
          Break;
        Inc(p);
        Dec(l);
      until l = 0;

      if l > 0 then
        begin
          Inc(p);
          Dec(l);
        end;

      SetString(Result, FTextPtr, FTextLength - l);
      Inc(FCount);

      if IncrementPos then
        begin
          FTextPtr := p;
          FTextLength := l;
        end;

    end
  else
    raise Exception.Create('TWordEnumerator.GetNext: No more words to return');
end;

{ ---------------------------------------------------------------------------- }

function TWordEnumerator.HasNext: Boolean;
begin
  Result := FTextLength > 0;
end;

{ ---------------------------------------------------------------------------- }

function TWordEnumerator.PeekNext: WideString;
begin
  Result := GetNext(False);
end;

{ ---------------------------------------------------------------------------- }

function TWordEnumerator.PopNext: WideString;
begin
  Result := GetNext(True);
end;

{ ---------------------------------------------------------------------------- }

procedure TWordEnumerator.Reset;
begin
  FTextPtr := Pointer(FText);
  FTextLength := Length(FText);
  FCount := 0;
end;

{ ---------------------------------------------------------------------------- }

procedure TWordEnumerator.SetText(const aText: WideString);
begin
  FText := aText;
  Reset;
end;

{ ---------------------------------------------------------------------------- }
{ TNodeObserverList
{ ---------------------------------------------------------------------------- }

var
  NodeObserverItemHandler: TDIItemHandler = nil;

function GetNodeObserverItemHandler: TDIItemHandler;
begin
  Result := NodeObserverItemHandler;
  if Result = nil then
    begin
      NodeObserverItemHandler := TDIItemHandler.Create;
      with NodeObserverItemHandler do
        begin
          ItemSize := SizeOf(TNodeObserver);
        end;
      Result := NodeObserverItemHandler;
    end;
end;

{ ---------------------------------------------------------------------------- }

function NewNodeObserverList: TNodeObserverList;
begin
  Result := TNodeObserverList.Create(GetNodeObserverItemHandler);
end;

{ ---------------------------------------------------------------------------- }

procedure TNodeObserverList.AddObserver(const AParentNode: TAreaNode; const AFirstStringNode: TStringNode);
begin
  with PNodeObserver(InsertItemLast)^ do
    begin
      ParentNode := AParentNode;
      FirstStringNode := AFirstStringNode;
    end;
end;

{ ---------------------------------------------------------------------------- }

function TNodeObserverList.GetObserver(const Index: Integer): PNodeObserver;
begin
  Result := PNodeObserver(PItemAt[Index]);
end;

{ ---------------------------------------------------------------------------- }

function TNodeObserverList.IndexOfStringNode(const Node: TStringNode): Integer;
var
  i: Integer;
begin
  for i := 0 to Count - 1 do
    if PNodeObserver(PItemAt[i])^.FirstStringNode = Node then
      begin
        Result := i;
        Exit;
      end;
  Result := -1;
end;

{ ---------------------------------------------------------------------------- }

procedure TNodeObserverList.SetObserver(const Index: Integer; const Value: PNodeObserver);
var
  Item: PNodeObserver;
begin
  Item := PItemAt[Index];
  // Clear the Item, as we are assigning an Interface.
  ItemHandler.OnInitItem(Self, Item);
  with PNodeObserver(InsertItemLast)^ do
    begin
      // Observer := Value.Observer;
      ParentNode := Value.ParentNode;
      FirstStringNode := Value.FirstStringNode;
    end;
end;

{ ---------------------------------------------------------------------------- }
{ TStringElement
{ ---------------------------------------------------------------------------- }

constructor TStringElement.Create(const Node: TStringNode; const Style: TFontStyles; const Color: TColor);
begin
  inherited Create;
  FNode := Node;
  FStyle := Style;
  FColor := Color;
end;

{ ---------------------------------------------------------------------------- }

function TStringElement.BeginsWithSpace: Boolean;
begin
  with FNode do
    Result := (Pointer(Text) <> nil) and (Text[1] = WC_SPACE);
end;

{ ---------------------------------------------------------------------------- }

function TStringElement.EndsWithSpace: Boolean;
begin
  with FNode do
    Result := (Pointer(Text) <> nil) and (Text[Length(Text)] = WC_SPACE);
end;

{ ---------------------------------------------------------------------------- }
{ TActionElement
{ ---------------------------------------------------------------------------- }

constructor TActionElement.Create(const ActionType: TActionType);
begin
  inherited Create;
  FActionType := ActionType;
end;

{ ---------------------------------------------------------------------------- }
{ TDIHtmlRenderer }
{ ---------------------------------------------------------------------------- }

procedure TDIHtmlRenderer.DoRenderNode(const Node: TAreaNode; const Styles: TFontStyles; const Color: TColor);
var
  i: Integer;
  ChildNode: TNode;
  NewStyles: TFontStyles;
  NewColor: TColor;
begin
  if FTextHandler.IsPosCurrent then
    Node.StartingPoint := Point(FTextHandler.PosX, FTextHandler.PosY)
  else
    FTextHandler.AddStartingPosObserver(Node);

  Node.Styles := Styles;
  Node.Color := Color;

  for i := 0 to Node.Children.Count - 1 do
    begin
      ChildNode := Node.Children[i];
      NewColor := TranslateColor(Color);
      NewStyles := Styles;

      case ChildNode.GetNodeType of

        ntActionNode:
          case TActionNode(ChildNode).Action of
            atLineBreak:
              FTextHandler.DoLineBreak;
            atParagraphBreak:
              FTextHandler.DoParagraphBreak;
          end;

        ntFontNode:
          begin
            NewColor := TFontNode(ChildNode).Color;
          end;

        ntLinkNode:
          begin
            NewStyles := Styles + FLinkStyle;
            NewColor := FLinkColor;
          end;

        ntStringNode:
          FTextHandler.TextOut(TStringNode(ChildNode), NewStyles, NewColor);

        ntStyleNode:
          NewStyles := Styles + [TStyleNode(ChildNode).Style];

      end;

      if ChildNode is TAreaNode then
        DoRenderNode(TAreaNode(ChildNode), NewStyles, NewColor);
    end;
end;

{ ---------------------------------------------------------------------------- }

procedure TDIHtmlRenderer.RenderNode(const Canvas: TCanvas; const Rect: TRect; const Node: TAreaNode);
begin
  FTextHandler := TTextHandler.Create(Canvas, Rect, Node.StartingPoint.x, Node.StartingPoint.y, FTextOffsetY);
  try
    DoRenderNode(Node, Node.Styles, Node.Color);
    FTextHandler.EmptyBuffer;
    FTextHeight := FTextHandler.GetTextHeight;
  finally
    FTextHandler.Free;
  end;
end;

{ ---------------------------------------------------------------------------- }

procedure TDIHtmlRenderer.RenderTree(const Canvas: TCanvas; Rect: TRect; const Tree: TNodeTree);
begin
  Tree.Root.StartingPoint := Point(Rect.Left, Rect.Top);
  RenderNode(Canvas, Rect, Tree.Root);
  Tree.Root.RetrieveRectsOfTLinkNodeChildren;
end;

{ ---------------------------------------------------------------------------- }

function TDIHtmlRenderer.TranslateColor(const Color: TColor): TColor;
begin
  Result := Color;
  case Result of
    clNormalLink:
      Result := FLinkColor;
    clClickedLink:
      Result := FLinkColorClicked;
    clHotLink:
      Result := FLinkColorHot;
  end;
end;

{ ---------------------------------------------------------------------------- }

initialization
  RegisterHtmlTags;
  RegisterTag(TAG_DYNAMIC, TAG_DYNAMIC_ID);
  RegisterHtmlAttribs;
  RegisterHtmlDecodingEntities;
  RegisterHtmlColors;

finalization
  NodeStackItemHandler.Free;
  RectItemHandler.Free;
  WordInfoItemHandler.Free;

  NodeObserverItemHandler.Free;

end.