Невизуальное дерево

=== Невизуальное дерево ===
unit EctoSoftTree;
{===============================================================================
 Класс TEctoSoftTree представляет собой невизуальное дерево для манипулирования
 древоподобными структурами в памяти. Мной в очередной раз из любви к искусству
 был изобретен велосипед :))), который тем не менее получился вполне съедобным
 и несмотря на наличие других вариантов решения задачи будет использоваться мной
 хотя бы назло врагам :) Буду рад если еще кому-то он придется по вкусу.
 Просьба при внесении изменений и дополнений в код, а также обнаружении ошибок
 (которых здесь нет ;) уведомить автора, т.е. меня
 Малышев Владимир aka "мыш"
 feedback@ectosoft.com
 http://www.EctoSoft.com
================================================================================}
interface
uses SysUtils, {EctoSysUtils,} Classes {EctoTypes,};
{ TEctoTreeNode class --------------------------------------------------------}
type TEctoSoftTree = class;
TEctoTreeNode = class(TObject)
 private
 FParentNode: TEctoTreeNode;
 function GetDescendantCount(): integer;
 function GetAbsoluteIndex(): integer;
 function GetChildIndex(): integer;
 function GetLevel(): integer;
 function GetPrevSibling(): TEctoTreeNode;
 function GetNextSibling(): TEctoTreeNode;
 function GetLastDescendant(): TEctoTreeNode;
 procedure SetParent(NewParentNode: TEctoTreeNode);
 public
 ParentTree: TEctoSoftTree;
 Children: TList;
 Data: Pointer;
 Caption: string;
 destructor Destroy(); override;
 constructor Create();
 function GetPrevChild(TargetChildNode: TEctoTreeNode): TEctoTreeNode;
 function GetNextChild(TargetChildNode: TEctoTreeNode): TEctoTreeNode;
 function GetLastChild(): TEctoTreeNode;
 function GetNext(): TEctoTreeNode;
 function GetPrev(): TEctoTreeNode;
 function IsRoot(): boolean;
 function IsParentOf(Node: TEctoTreeNode): boolean;
 procedure MoveUp();
 procedure MoveDown();
 procedure MoveLeft();
 procedure MoveRight();
 procedure Sort(Compare: TListSortCompare; SortSubtrees: boolean);
 property AbsoluteIndex: integer read GetAbsoluteIndex;
 property Index: integer read GetChildIndex;
 property PrevSibling: TEctoTreeNode read GetPrevSibling;
 property NextSibling: TEctoTreeNode read GetNextSibling;
 property LastDescendant: TEctoTreeNode read GetLastDescendant;
 property DescendantCount: integer read GetDescendantCount;
 property Level: integer read GetLevel;
 property ParentNode: TEctoTreeNode read FParentNode write SetParent;
end;
TOnFreeNodeEvent = procedure(Node: TEctoTreeNode) of object;
{ TEctoSoftTree class --------------------------------------------------------}
TEctoSoftTree = class(TObject)
 private
 FOnFreeNodeEvent: TOnFreeNodeEvent;
 function GetNodeFromIndex(Index:integer): TEctoTreeNode;
 function GetNodeCount(): integer;
 public
 Root: TEctoTreeNode;
 function FindNode(FindCaption: string): TEctoTreeNode;
 procedure DeleteNode(Index: integer); overload;
 procedure DeleteNode(DeletingNode: TEctoTreeNode); overload;
 function AddNode(aParentNode:TEctoTreeNode):
 TEctoTreeNode; overload;
 function AddNode(aParentNode:TEctoTreeNode; Caption: string):
 TEctoTreeNode; overload;
 function AddNode(aParentNode:TEctoTreeNode; Data: Pointer):
 TEctoTreeNode; overload;
 function AddNode(aParentNode:TEctoTreeNode; Caption: string; Data: Pointer):
 TEctoTreeNode; overload;
 procedure Clear(); 
 destructor Destroy; override;
 property Nodes[Index:integer] : TEctoTreeNode read GetNodeFromIndex;
 property NodeCount: integer read GetNodeCount;
 property OnFreeNode: TOnFreeNodeEvent read FOnFreeNodeEvent write
 FOnFreeNodeEvent;
end;
implementation
{ TEctoSoftTree }
function TEctoSoftTree.AddNode(aParentNode: TEctoTreeNode; Caption: string;
 Data: Pointer): TEctoTreeNode;
var
 NewNode: TEctoTreeNode;
begin
 NewNode := TEctoTreeNode.Create;
 if Root = nil then
 begin
 NewNode.FParentNode := nil;
 Root := NewNode;
 end
 else
 begin
 if aParentNode = nil then
 Raise EInvalidOperation.Create('Parent node must exists');
 NewNode.FParentNode := aParentNode;
 aParentNode.Children.Add(NewNode);
 end;
 NewNode.Caption := Caption;
 NewNode.Data := Data;
 NewNode.ParentTree := self;
 Result := NewNode; 
end;
function TEctoSoftTree.AddNode(aParentNode: TEctoTreeNode): TEctoTreeNode;
begin
 Result := AddNode(aParentNode, , nil);
end;
function TEctoSoftTree.AddNode(aParentNode: TEctoTreeNode;
 Caption: string): TEctoTreeNode;
begin
 Result := AddNode(aParentNode, Caption, nil);
end;
function TEctoSoftTree.AddNode(aParentNode: TEctoTreeNode; Data: Pointer): TEctoTreeNode;
begin
 Result := AddNode(aParentNode, , Data);
end;
procedure TEctoSoftTree.Clear;
begin
 if Root = nil then exit;
 Root.Free;
 Root := nil;
end;
procedure TEctoSoftTree.DeleteNode(Index: integer);
begin
 DeleteNode(Nodes[Index]);
end;
procedure TEctoSoftTree.DeleteNode(DeletingNode: TEctoTreeNode);
begin
 if DeletingNode.IsRoot then
 // Рут не нужно исключать из родительского списка, поэтому просто освобождаем
 FreeAndNil(Root)
 else
 begin
 // обращение к ParentNode без проверки на его существование обусловлено тем,
 // что раз это не Root, значит у него обязательно есть Parent
 DeletingNode.FParentNode.Children.Delete 
 (DeletingNode.FParentNode.Children.IndexOf(DeletingNode));
 FreeAndNil(DeletingNode);
 end;
end;
destructor TEctoSoftTree.Destroy;
begin
 Clear();
 inherited;
end;
{ функция FindNode пока ищет только первое вхождение узла с заданным сaption
 - надо доработать}
function TEctoSoftTree.FindNode(FindCaption: string): TEctoTreeNode;
 procedure FindNode_(TargetNode: TEctoTreeNode);
 var
 i: Integer;
 begin
 // выходим из всех рекурсий, если где-то в одной из них ранее уже был найден узел
 if Result <> nil then exit; 
 { проверяем вызванный узел TargetNode на соответствие }
 if TargetNode.Caption = FindCaption then
 begin
 Result := TargetNode;
 exit;
 end;
 { вызываем всех детей узла TargetNode для их проверки }
 i := 0;
 while i < TargetNode.Children.Count do
 begin
 FindNode_(TEctoTreeNode(TargetNode.Children.Items[i]));
 Inc(i);
 end;
 end;
begin
 Result := nil;
 FindNode_(Root);
end;
function TEctoSoftTree.GetNodeCount: integer;
begin
 if Root = nil then
 Result := 0
 else 
 Result := Root.GetDescendantCount+1; // +1 - Учитываем Root
end;
{ функция GetNodeFromIndex - "движок" для Nodes[Index: integer] }
function TEctoSoftTree.GetNodeFromIndex(Index: integer): TEctoTreeNode;
var
 IndexCounter: integer;
 procedure CompareNodeIndex(Node: TEctoTreeNode);
 var
 i: integer;
 begin
 { блок 1 проверяем вызванный узел }
 Inc(IndexCounter);
 if IndexCounter = Index then
 begin
 Result := Node;
 exit;
 end;
 { вызываем дочерние узлы чтобы выполнить в них предыдущий блок - блок 1 }
 i := 0; 
 while i < Node.Children.Count do
 begin
 CompareNodeIndex(TEctoTreeNode(Node.Children[i]));
 Inc(i);
 end;
 end;
begin
 IndexCounter := -1;
 Result := nil;
 CompareNodeIndex(Root);
 if (Result = nil) then
 Raise EInvalidOperation.Create('Wrong index');
end;
{ TEctoTreeNode }
constructor TEctoTreeNode.Create;
begin
 Children := TList.Create;
end;
destructor TEctoTreeNode.Destroy;
var
 i: integer;
begin
 if Assigned(ParentTree.FOnFreeNodeEvent) then
 ParentTree.FOnFreeNodeEvent(self);
 i := 0;
 while i < Children.Count do
 begin
 TEctoTreeNode(Children.Items[i]).Free;
 Inc(i);
 end;
 Children.Free;
 inherited;
end;
function TEctoTreeNode.GetAbsoluteIndex: integer;
var
 Node: TEctoTreeNode;
begin
 if IsRoot then
 Result := 0
 else
 begin
 Result := -1;
 Node := Self;
 while Node <> nil do
 begin
 Inc(Result);
 Node := Node.GetPrev;
 end;
 end;
end;
{ функция GetDescendantCount возвращает количество всех потомков данного узла,
 включая дочерние узлы и их потомки }
function TEctoTreeNode.GetChildIndex: integer;
begin
 Result := -1;
 if IsRoot then exit;
 Result := ParentNode.Children.IndexOf(self);
end;
function TEctoTreeNode.GetDescendantCount: integer;
var
 Node: TEctoTreeNode;
begin
 Result := 0;
 Node := Self.GetLastDescendant;
 if Node = nil then exit;
 while (Node <> self) do
 begin
 Inc(Result);
 Node := Node.GetPrev;
 end;
end;
{ функция GetLastChild возвращает последний дочерний узел текущего. Возвращает
 nil в случае если узел не имеет дочерних узлов, что и обуславливает
 необходимость данной функции }
function TEctoTreeNode.GetLastChild: TEctoTreeNode;
begin
 Result := nil;
 if Children.Count > 0 then
 Result := TEctoTreeNode(Children[Children.Count-1]);
end;
{ функция GetLastDescendant возвращает последнего потомка текущего узла. Учитываются не только
 прямые потомки (дочерние узлы) но и дальние (их потомки) }
function TEctoTreeNode.GetLastDescendant(): TEctoTreeNode;
var
 Node: TEctoTreeNode;
begin
 Node := self;
 while Node.GetLastChild <> nil do
 Node := Node.GetLastChild();
 if Node = self then Node := nil;
 Result := Node;
end;
function TEctoTreeNode.GetLevel: integer;
var
 Node: TEctoTreeNode;
begin
 Result := 0;
 if IsRoot then exit;
 Node := self;
 while Node <> ParentTree.Root do
 begin
 Inc(Result);
 Node := Node.FParentNode;
 end;
end;
{ GetNext возвращает следующий узел по ходу "рекурсивного" обхода дерева }
function TEctoTreeNode.GetNext: TEctoTreeNode;
var
 Node : TEctoTreeNode;
begin
 Result := nil;
 // Если у узла есть дочерние узлы, то следующим за ним будет очевидно первый дочерний
 if Children.Count > 0 then
 result := TEctoTreeNode(Children[0]);
 // Если дочерних нет... то следующим будет следующий сестринский узел
 if Result = nil then
 Result := GetNextSibling();
 // Если и дочерних и сестринских нет, а также это не рут, то следующим будет 
 // первый сестринский узел родителя
 if (result = nil) and (not IsRoot) then
 begin
 Node := FParentNode;
 // У родителя может не оказаться сестринских узлов, тогда проводим поиск 
 // (идя назад) первого родителя (беря "родителя родителя") у которого будет сестринский узел
 while (Node.GetNextSibling = nil) and (not Node.IsRoot) do
 Node := Node.FParentNode;
 if not Node.IsRoot then
 result := Node.GetNextSibling;
 end; 
end;
{ функция GetNextChild возвращает следующий дочерний узел отсчитывая от
 заданного дочернего узла. Если заданный узел является последним дочерним
 узлом, функция возвращает nil }
function TEctoTreeNode.GetNextChild(TargetChildNode: TEctoTreeNode): TEctoTreeNode;
var
 NextChildIndex: integer;
begin
 Result := nil;
 NextChildIndex := Children.IndexOf(TargetChildNode)+1;
 if (NextChildIndex < Children.Count) and (NextChildIndex > 0) then
 Result := TEctoTreeNode(Children[NextChildIndex]);
end;
function TEctoTreeNode.GetNextSibling: TEctoTreeNode;
begin
 if IsRoot then
 Result := nil
 else
 Result := FParentNode.GetNextChild(Self);
end;
{ GetPrev возвращает предыдущий узел по ходу рекурсивного обхода дерева }
function TEctoTreeNode.GetPrev: TEctoTreeNode;
var
 Node: TEctoTreeNode;
begin
 Result := nil;
 if IsRoot then
 exit;
 // получаем предыдущий сестринский узел
 Result := GetPrevSibling();
 // если его нет, значит наш узел первый, значит предыдущим будет его родитель
 if Result = nil then
 Result := FParentNode
 else
 begin
 // а если есть.. получаем последнего потомка
 Node := result.LastDescendant;
 // если такой существует (если вообще есть потомки) то он и будет предыдущим.
 // Если же не существует, то result остается со значением полученным в строке result := GetPrevSibling();
 if Node <> nil then Result := Node; 
 end;
end;
{ функция GetPrevChild возвращает предыдущий дочерний узел отсчитывая от
 заданного дочернего узла. Если заданный узел является первым дочерним
 узлом, функция возвращает nil }
function TEctoTreeNode.GetPrevChild(TargetChildNode: TEctoTreeNode): TEctoTreeNode;
var
 PrevChildIndex:integer;
begin
 Result := nil;
 PrevChildIndex := Children.IndexOf(TargetChildNode)-1;
 if PrevChildIndex > -1 then
 Result := TEctoTreeNode(Children[PrevChildIndex]);
end;
function TEctoTreeNode.GetPrevSibling: TEctoTreeNode;
begin
 if IsRoot then
 Result := nil
 else
 Result := FParentNode.GetPrevChild(Self);
end;
{ функция IsParentOf возвращает true если узел является предком заданного
 в независимости от их уровня }
function TEctoTreeNode.IsParentOf(Node: TEctoTreeNode): boolean;
var
 TempNode: TEctoTreeNode;
begin
 Result := false;
 TempNode := Node.FParentNode;
 while TempNode<>nil do
 begin
 if TempNode = self then
 begin
 Result := true;
 exit;
 end;
 TempNode := TempNode.FParentNode;
 end;
end;
function TEctoTreeNode.IsRoot: boolean;
begin
 Result := (Self = ParentTree.Root);
end;
{ процедура MoveDown перемещает узел вниз. Перемещение возможно только в
 пределах сестринских узлов, если узел является последним в списке детей
 текущего родителя, то перемещение невозможно }
procedure TEctoTreeNode.MoveDown;
var
 Temp: Pointer;
 ChildIndex: integer;
begin
 if IsRoot then exit;
 if NextSibling <> nil then
 begin
 // временная переменная ChildIndex нужна т.к. Index - расчетное свойство, 
 // незачем лишние вызовы. Кроме того после первого оператора индекс теряется
 ChildIndex := Index;
 Temp := ParentNode.Children[ChildIndex];
 ParentNode.Children[ChildIndex] := ParentNode.Children[ChildIndex+1];
 ParentNode.Children[ChildIndex+1] := Temp;
 end;
end;
{ процедура MoveLeft перемещает узел влево. Перемещение идет по принципу:
 новым родителем становится родитель родителя, а узел вставляется в список
 дочерних узлов родителя родителя таким образом, чтобы оказаться сразу после
 текущего родителя (текущий родитель после перемещения становится предыдущим
 сестринским узлом) }
procedure TEctoTreeNode.MoveLeft;
begin
 if (ParentNode.IsRoot) or (IsRoot) then exit;
 ParentNode.ParentNode.Children.Insert(ParentNode.Index+1, self);
 ParentNode.Children.Delete(ParentNode.Children.IndexOf(self));
 // FParentNode используем вместо ParentNode потому что нам не нужен вызов 
 // всей процедуры присваивания родителя, мы всю работу делаем здесь сами и она специфична.
 FParentNode := ParentNode.ParentNode;
end;
{ процедура MoveRight перемещает узел вправо. Перемещение идет по принципу:
 новым родителем становится предыдущий сестринский узел. Если предыдущего
 сестринского узла нет, перемещение считается невозможным }
procedure TEctoTreeNode.MoveRight;
begin
 // Если нет сестринского узла перед этим, то невозможно движение вправо
 if (IsRoot) or (PrevSibling=nil) then exit;
 // Здесь вызов процедуры присваивания родителя.
 ParentNode := PrevSibling;
end;
{ процедура MoveUp перемещает узел вверх. Перемещение идет по принципу:
 если у узла есть сестринские узлы выше него, то узел просто встает выше
 предыдущего сестринского узла. Если же сестринских узлов выше нет (узел первый
 дочерний у родителя), то узел становится выше родительского, т.е. в конец
 дочерних узлов предыдущего сестринского узла родителя. }
procedure TEctoTreeNode.MoveUp;
var
 Temp: Pointer;
 ChildIndex: integer;
begin
 if IsRoot then exit;
 if PrevSibling <> nil then
 begin
 // временная переменная ChildIndex нужна т.к. Index - расчетное свойство, 
 // незачем лишние вызовы. Кроме того после первого оператора индекс теряется
 ChildIndex := Index;
 Temp := ParentNode.Children[ChildIndex];
 ParentNode.Children[ChildIndex] := ParentNode.Children[ChildIndex-1];
 ParentNode.Children[ChildIndex-1] := Temp;
 end
 else
 begin
 if not ParentNode.IsRoot then
 begin
 // Это присваивание автоматически добавит узел в конец, последним дочерним.
 ParentNode := ParentNode.ParentNode;
 MoveUp;
 end;
 end;
end;
{ установка нового родителя функцией SetParent фактически означает перенос
 ветви дерева в другую ветвь }
procedure TEctoTreeNode.SetParent(NewParentNode: TEctoTreeNode);
begin
 if (NewParentNode = nil) or (NewParentNode = self) then exit;
 ParentNode.Children.Delete(ParentNode.Children.IndexOf(self));
 NewParentNode.Children.Add(self);
 self.FParentNode := NewParentNode;
end;
procedure TEctoTreeNode.Sort(Compare: TListSortCompare; SortSubtrees: boolean);
var
 i, j, CompareResult: integer;
 Temp: Pointer;
begin
 j := 0;
 while j < Children.Count do
 begin
 i := Children.Count-1;
 while i > j do
 begin
 if i > j then
 begin
 CompareResult := Compare(Children[i], Children[i-1]);
 if CompareResult > 0 then
 begin
 Temp := Children[i-1];
 Children[i-1] := Children[i];
 Children[i] := Temp;
 end;
 end;
 Dec(i);
 end;
 if SortSubtrees then
 TEctoTreeNode(Children[j]).Sort(Compare, true);
 Inc(j);
 end;
end;
end.
Source: Взято из http://forum.sources.ru
ID: 00640