RnQ/for.RnQ/VTV/Contributions/GenericWrapper/VirtualTreeWrapper.pas

unit VirtualTreeWrapper;

// The contents of this file are subject to
// GNU Lesser General Public License as published by the Free Software Foundation;
// either version 2.1 of the License, or (at your option) any later version.
// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/.
//
// Software distributed under the License is distributed on an "AS IS" basis,
// WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the
// specific language governing rights and limitations under the License.
//
// Original code released 02-15-2011
//
// Copyright (C) 2011 VUTS Liberec (Jan Rames ramejan@gmail.com)

interface

uses SysUtils, Classes, Controls, VirtualTrees, Generics.Collections.Static,
     RTLConsts;

type
  ///

  ///    Provides basic record wrapper functionality in terms of initializating
  ///    and finalizating the record's members (strings, interfaces) to prevent
  ///    memory leaks
  ///
  TBaseVirtualTreeWrapper = class(TComponent)
  public
	type P = ^T;
	type TFreeProc = reference to procedure(var UserData : T);
  private
	FFreeNode	: TVTFreeNodeEvent;
	FFreeProc	: TFreeProc;
  protected
	///

	///    Assigns Tree's Properties and Events
	///
	procedure Init; virtual;
	function Tree : TVirtualStringTree; inline;

	//No virtual functions needed, just reassign particular events in create
	//of descendants
	{procedure InitNode(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode;
	  var InitialStates: TVirtualNodeInitStates); Cannot be relied upon, it'll
	  be called later even after the AddChild returns}
	procedure FreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
  public
	constructor Create(AOwner : TComponent); overload; override;
	constructor Create(AOwner : TComponent; FreeProc : TFreeProc); reintroduce; overload;

	///

	///    Adds a node and initializes its data (do not ever call
	///    TVirtualStringTree.AddChild as it would fail to initialize it)
	///
	function AddChild(Parent : PVirtualNode) : PVirtualNode; inline;
	function GetUserData(Node : PVirtualNode) : P; inline;

	property Data[Node : PVIrtualNode] : P read GetUserData;
  end;

  TVirtualTreeWrapper = class;

  ///

  ///    Record that stores Item's common data
  ///
  TVSTData = record
	Caption		: string;
	Hint		: string;
	ImageIndex	: Integer;
  end;
  PVSTData = ^TVSTData;

  TVirtualNodeEnumerator = class;
  ///

  ///    Record that can be used to operate the node with object-like manner
  ///
  TVirtualNode = record
  strict private
	Tree	: TVirtualTreeWrapper;
	FNode	: PVirtualNode;
	FData	: PVSTData;

	function GetData : TBaseVirtualTreeWrapper.P;

	function GetCaption : string;
	procedure SetCaption(const ACaption : string);
	function GetHint : string;
	procedure SetHint(const AHint : string);
	function GetImageIndex : Integer;
	procedure SetImageIndex(const AImageIndex : Integer);
	function GetCheckState : TCheckState;
	procedure SetCheckState(Value: TCheckState);
	function GetCheckType : TCheckType;
	procedure SetCheckType(Value: TCheckType);
	function GetLevel : Integer;
	function GetIndex : Integer;
	function GetItem(Index : Cardinal) : TVirtualNode;
	function GetChildCount : Cardinal;

  private
	procedure Create(ATree : TVirtualTreeWrapper; ANode : PVirtualNode);
	function GetIsEmpty: Boolean;
  public
	class function Empty : TVirtualNode; static;

	function AddChild : TVirtualNode; overload;
	function AddChild(const ACaption : string) : TVirtualNode; overload;
	procedure Delete;
	procedure MakeVisible(Recursive : Boolean = false);

	function Parent: TVirtualNode;
	function FirstChild : TVirtualNode;
	function NextSibling : TVirtualNode;
	function PrevSiblinng : TVirtualNode;

	function GetEnumerator : TVirtualNodeEnumerator;

	property Node		: PVirtualNode read FNode;
	property Level		: Integer	read GetLevel;
	property Index		: Integer	read GetIndex;
	property ChildCount	: Cardinal	read GetChildCount;
	property Data		: TBaseVirtualTreeWrapper.P read GetData;
	property Caption	: string	read GetCaption		write SetCaption;
	property Hint		: string	read GetHint		write SetHint;
	property ImageIndex	: Integer	read GetImageIndex	write SetImageIndex;
	property CheckState	: TCheckState read GetCheckState write SetCheckState;
	property CheckType	: TCheckType read GetCheckType	write SetCheckType;
	property Items[Index : Cardinal]	: TVirtualNode read GetItem; default;
	property IsEmpty	: Boolean	read GetIsEmpty;
  end;

  ///

  ///    Provides enhanced record wrapper functionality with caption, hint, etc.
  ///    make sure that your record begins with TVSTData:
  ///    record
  ///        Info : TVSTData;
  ///        Data1: Type1;
  ///        Data2: Type2;
  ///        ...
  ///    end;
  ///
  TVirtualTreeWrapper = class(TBaseVirtualTreeWrapper)
  public
	type P = TBaseVirtualTreeWrapper.P;
  private
  	FUpdateCount	: Integer;
	function GetItem(Node: PVirtualNode): TVirtualNode; inline;
  protected
	procedure Init; override;
	function GetData(Node : PVirtualNode) : PVSTData; inline;
	procedure NodeUpdated(Node : PVirtualNode); inline;

	//No virtual functions needed, just reassign particular events in create
	//of descendants

	procedure DoGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
	  Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);
	procedure DoGetHint(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;
	  var LineBreakStyle: TVTTooltipLineBreakStyle; var HintText: UnicodeString);
	procedure DoGetImageIndex(Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;
	  var Ghosted: Boolean; var ImageIndex: Integer);
  public
	constructor Create(AOwner : TComponent); override;

	function AddChild(ParentNode : PVirtualNode) : PVirtualNode; overload; inline;
	function AddChild(ParentNode : PVirtualNode; const Caption : UnicodeString) : PVirtualNode; overload; inline;
	function AddChild(ParentNode : PVirtualNode; const Caption, Hint : UnicodeString) : PVirtualNode; overload; inline;
	procedure DeleteNode(Node: PVirtualNode); inline;

	function GetCaption(Node : PVirtualNode) : string; inline;
	procedure SetCaption(Node : PVirtualNode; const ACaption : string); inline;
	function GetHint(Node : PVirtualNode) : string; inline;
	procedure SetHint(Node : PVirtualNode; const AHint : string); inline;
	function GetImageIndex(Node : PVirtualNode) : Integer; inline;
	procedure SetImageIndex(Node : PVirtualNode; const AImageIndex : Integer); inline;

	///

	///    Finds node with given Caption returns first node found or nil
	///    (if no match was found). Search is only limited to Childs of
	///    ParentNode. If ParentNode is nil, base of the tree is searched.
    ///    For extended search use Incremental search feature of the VirtualTree
    ///
	function FindNode(const ACaption : string; ParentNode : PVirtualNode = nil) : PVirtualNode;

	procedure BeginUpdate;
	procedure EndUpdate;

	///

	///    Returns IVirtualNode nased on PVirtualNode (if set to nil, root is
	///    returned)
    ///
	property Items[Node : PVirtualNode] : TVirtualNode	read GetItem; default;
  end;

  TVirtualNodeEnumerator = class
  strict private
	Node	: PVirtualNode;
	FCurrent : PVirtualNode;
	Tree	: TVirtualTreeWrapper;
	function GetCurrent	: TVirtualNode; inline;
  public
	constructor Create(ATree : TVirtualTreeWrapper; ANode : PVirtualNode);
	function MoveNext : Boolean; inline;
	property Current : TVirtualNode read GetCurrent;
  end;

implementation

{ TBaseVirtualTreeViewWrapper }

function TBaseVirtualTreeWrapper.AddChild(Parent: PVirtualNode): PVirtualNode;
var Ptr	: P;
begin
	Result:=Tree.AddChild(Parent);
	//Treat the node as if it has some initial data which causes calling of
	//OnFreeNode even if the node hasn't been already initialized
	Include(Result^.States, vsInitialUserData);
	Ptr:=Tree.GetNodeData(Result);
	//Not needed as VirtualTree uses AllocMem which nils (it zeros the entire
	//memory block) all pointers that Initialize nils (basically this is the
	//same thing that SetLength for dynamic arrays does).
	//Initialize(Ptr^);
end;

constructor TBaseVirtualTreeWrapper.Create(AOwner: TComponent; FreeProc : TFreeProc);
begin
	Create(AOwner);
	FFreeProc:=FreeProc;
end;

constructor TBaseVirtualTreeWrapper.Create(AOwner: TComponent);
begin
	inherited Create(AOwner as TVirtualStringTree);	//Make sure Owner is set correctly
	Init;
end;

procedure TBaseVirtualTreeWrapper.FreeNode(Sender: TBaseVirtualTree;
  Node: PVirtualNode);
var P	: ^T;
begin
	if (Assigned(FFreeNode)) then FFreeNode(Sender, Node);

	P:=Sender.GetNodeData(Node);
	if (Assigned(FFreeProc)) then FFreeProc(P^);

	Finalize(P^);
end;

function TBaseVirtualTreeWrapper.GetUserData(Node: PVirtualNode): P;
begin
	Result:=Tree.GetNodeData(Node);
end;

procedure TBaseVirtualTreeWrapper.Init;
begin
	Tree.NodeDataSize:=sizeof(T);

	//Tree.OnInitNode:=InitNode;
	FFreeNode:=Tree.OnFreeNode;
	Tree.OnFreeNode:=FreeNode;
end;

function TBaseVirtualTreeWrapper.Tree: TVirtualStringTree;
begin
	Result:=TVirtualStringTree(Owner);
end;

{ TVirtualTreeViewWrapper }

function TVirtualTreeWrapper.AddChild(ParentNode: PVirtualNode): PVirtualNode;
var Data	: P;
begin
	Result:=inherited AddChild(ParentNode);
	Data:=GetUserData(Result);
	PVSTData(Data)^.ImageIndex:=-1;
end;

function TVirtualTreeWrapper.AddChild(ParentNode: PVirtualNode;
  const Caption: UnicodeString): PVirtualNode;
var Data	: P;
begin
	Result:=inherited AddChild(ParentNode);
	Data:=GetUserData(Result);
	PVSTData(Data)^.Caption:=Caption;
	PVSTData(Data)^.ImageIndex:=-1;
	NodeUpdated(Result);
end;

function TVirtualTreeWrapper.AddChild(ParentNode: PVirtualNode;
  const Caption, Hint: UnicodeString): PVirtualNode;
var Data	: P;
begin
	Result:=inherited AddChild(ParentNode);
	Data:=GetUserData(Result);
	PVSTData(Data)^.Caption:=Caption;
	PVSTData(Data)^.Hint:=Hint;
	PVSTData(Data)^.ImageIndex:=-1;
	NodeUpdated(Result);
end;

procedure TVirtualTreeWrapper.BeginUpdate;
begin
	Inc(FUpdateCount);
	Tree.BeginUpdate;
end;

constructor TVirtualTreeWrapper.Create(AOwner: TComponent);
begin
	inherited;
	FUpdateCount:=0;
end;

procedure TVirtualTreeWrapper.EndUpdate;
begin
	Dec(FUpdateCount);
	Tree.EndUpdate;
	if (FUpdateCount <= 0) then begin
		//Tree.InvalidateChildren(nil, true);
		FUpdateCount:=0;
	end;
end;

function TVirtualTreeWrapper.FindNode(const ACaption: string;
  ParentNode: PVirtualNode = nil): PVirtualNode;
begin
	if (ParentNode = nil) then ParentNode:=Tree.RootNode;

	ParentNode:=ParentNode^.FirstChild;
	Result:=nil;
	while ParentNode <> nil do begin
		if (GetData(ParentNode)^.Caption = ACaption) then Exit(ParentNode);
		ParentNode:=ParentNode.NextSibling;
	end;
end;

function TVirtualTreeWrapper.GetCaption(Node: PVirtualNode): string;
begin
	Result:=GetData(Node)^.Caption;
end;

function TVirtualTreeWrapper.GetData(Node: PVirtualNode): PVSTData;
begin
	Result:=Tree.GetNodeData(Node);
end;

function TVirtualTreeWrapper.GetHint(Node: PVirtualNode): string;
begin
	Result:=GetData(Node)^.Hint;
end;

function TVirtualTreeWrapper.GetImageIndex(Node: PVirtualNode): Integer;
begin
	Result:=GetData(Node)^.ImageIndex;
end;

function TVirtualTreeWrapper.GetItem(Node: PVirtualNode): TVirtualNode;
begin
	Result.Create(Self, Node);
end;

procedure TVirtualTreeWrapper.DeleteNode(Node: PVirtualNode);
begin
	Tree.DeleteNode(Node);
end;

procedure TVirtualTreeWrapper.DoGetHint(Sender: TBaseVirtualTree;
  Node: PVirtualNode; Column: TColumnIndex;
  var LineBreakStyle: TVTTooltipLineBreakStyle; var HintText: UnicodeString);
begin
	HintText:=GetData(Node)^.Hint;
end;

procedure TVirtualTreeWrapper.DoGetImageIndex(Sender: TBaseVirtualTree;
  Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;
  var Ghosted: Boolean; var ImageIndex: Integer);
begin
	ImageIndex:=GetData(Node)^.ImageIndex;
end;

procedure TVirtualTreeWrapper.DoGetText(Sender: TBaseVirtualTree;
  Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;
  var CellText: string);
begin
	CellText:=GetData(Node)^.Caption;
end;

procedure TVirtualTreeWrapper.Init;
begin
	inherited;

	Tree.OnGetText:=DoGetText;
	Tree.OnGetHint:=DoGetHint;
	Tree.OnGetImageIndex:=DoGetImageIndex;
end;

procedure TVirtualTreeWrapper.NodeUpdated(Node: PVirtualNode);
begin
	if (FUpdateCount = 0) then Tree.InvalidateNode(Node);
end;

procedure TVirtualTreeWrapper.SetCaption(Node: PVirtualNode;
  const ACaption: string);
begin
	GetData(Node)^.Caption:=ACaption;
	NodeUpdated(Node);
end;

procedure TVirtualTreeWrapper.SetHint(Node: PVirtualNode; const AHint: string);
begin
	GetData(Node)^.Hint:=AHint;
	NodeUpdated(Node);
end;

procedure TVirtualTreeWrapper.SetImageIndex(Node: PVirtualNode;
  const AImageIndex: Integer);
begin
	NodeUpdated(Node);
end;

{ TVirtualNodeImpl }

function TVirtualNode.AddChild: TVirtualNode;
begin
	Result.Create(Tree, Tree.AddChild(FNode));
end;

function TVirtualNode.AddChild(const ACaption: string): TVirtualNode;
begin
	Result.Create(Tree, Tree.AddChild(FNode, ACaption));
end;

procedure TVirtualNode.Create(ATree: TVirtualTreeWrapper;
  ANode: PVirtualNode);
begin
	Tree:=ATree;
	FNode:=ANode;
	if (FNode = nil) then FData:=nil
	else FData:=ATree.GetData(FNode);
end;

function TVirtualNode.GetCaption: string;
begin
	Result:=FData^.Caption;
end;

function TVirtualNode.GetCheckState: TCheckState;
begin
	Result:=Tree.Tree.CheckState[FNode];
end;

function TVirtualNode.GetCheckType: TCheckType;
begin
	Result:=Tree.Tree.CheckType[FNode];
end;

function TVirtualNode.GetChildCount: Cardinal;
begin
	Result:=FNode^.ChildCount;
end;

function TVirtualNode.GetData: TBaseVirtualTreeWrapper.P;
begin
	Result:=Pointer(FData);
end;

function TVirtualNode.GetEnumerator: TVirtualNodeEnumerator;
begin
	Result:=TVirtualNodeEnumerator.Create(Tree, FNode);
end;

function TVirtualNode.GetHint: string;
begin
	Result:=FData^.Hint;
end;

function TVirtualNode.GetImageIndex: Integer;
begin
	Result:=FData^.ImageIndex;
end;

function TVirtualNode.GetIndex: Integer;
begin
	Result:=FNode^.Index;
end;

function TVirtualNode.GetIsEmpty: Boolean;
begin
	Result:=FNode = nil;
end;

function TVirtualNode.GetItem(Index: Cardinal): TVirtualNode;
var i		: Integer;
	ANode	: PVirtualNode;
begin
	if (Index >= FNode^.ChildCount) then
		raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange);

	ANode:=FNode^.FirstChild;
	if (Index > 0) then for i:=0 to Index - 1 do begin
		Assert(ANode <> nil, 'Node shouldn''t be nil, ChildCount incorrect');
		ANode:=ANode^.NextSibling;
	end;
	Result:=Tree.GetItem(ANode);
end;

function TVirtualNode.GetLevel: Integer;
begin
	Result:=Tree.Tree.GetNodeLevel(FNode);
end;

procedure TVirtualNode.MakeVisible(Recursive: Boolean);
var AParent	: PVirtualNode;
	List	: TList;
	i		: Integer;
begin
	with Tree.Tree do begin
		List.Init;
		AParent:=FNode.Parent;
		// The root node is marked by having its NextSibling (and PrevSibling) pointing to itself.
		while (AParent <> nil) and (AParent^.NextSibling <> AParent) do begin
			if (vsExpanded in AParent^.States) then Break;
			List.Add(AParent);
			AParent:=AParent^.Parent;
		end;
		for i:=List.Count - 1 downto 0 do Expanded[List[i]]:=true;

		if (Recursive) then FullExpand(FNode)
		else Expanded[FNode]:=true;
    end;
end;

function TVirtualNode.NextSibling: TVirtualNode;
begin
	if (FNode^.NextSibling = nil) then Exit(Empty);
	
	Result:=Tree.GetItem(FNode^.NextSibling);
end;

function TVirtualNode.Parent: TVirtualNode;
begin
	Result:=Tree.GetItem(FNode^.Parent);
end;

function TVirtualNode.PrevSiblinng: TVirtualNode;
begin
	if (FNode^.PrevSibling = nil) then Exit(Empty);
	
	Result:=Tree.GetItem(FNode^.PrevSibling);
end;

procedure TVirtualNode.Delete;
begin
	Tree.DeleteNode(FNode);
end;

class function TVirtualNode.Empty: TVirtualNode;
begin
	Result.FNode:=nil;
	Result.FData:=nil;
end;

function TVirtualNode.FirstChild: TVirtualNode;
begin
	if (FNode^.FirstChild = nil) then Exit(Empty);
	
	Result:=Tree.GetItem(FNode^.FirstChild);
end;

procedure TVirtualNode.SetCaption(const ACaption: string);
begin
	FData^.Caption:=ACaption;
	Tree.NodeUpdated(FNode);
end;

procedure TVirtualNode.SetCheckState(Value: TCheckState);
begin
	Tree.Tree.CheckState[FNode]:=Value;
end;

procedure TVirtualNode.SetCheckType(Value: TCheckType);
begin
	Tree.Tree.CheckType[FNode]:=Value;
end;

procedure TVirtualNode.SetHint(const AHint: string);
begin
	FData^.Hint:=AHint;
	Tree.NodeUpdated(FNode);
end;

procedure TVirtualNode.SetImageIndex(const AImageIndex: Integer);
begin
	FData^.ImageIndex:=AImageIndex;
	Tree.NodeUpdated(FNode);
end;

{ TVirtualNodeEnumerator }

constructor TVirtualNodeEnumerator.Create(ATree : TVirtualTreeWrapper; 
	ANode: PVirtualNode);
begin
	Node:=ANode;
	FCurrent:=nil;
	Tree:=ATree;
end;

function TVirtualNodeEnumerator.GetCurrent: TVirtualNode;
begin
	Result:=Tree.GetItem(FCurrent);
end;

function TVirtualNodeEnumerator.MoveNext: Boolean;
begin
	if (FCurrent = nil) then FCurrent:=Node^.FirstChild
	else FCurrent:=FCurrent^.NextSibling;

	Result:=FCurrent <> nil;
end;

end.