{$MODE OBJFPC}
{$MODESWITCH AUTODEREF}
{$MODESWITCH NESTEDPROCVARS}
unit dimbeddedtree;

interface

type
generic TImbeddedTree<PItem> = object
type
  TPtr = ^TImbeddedTree;
public
  Parent: PItem;
  Sub: array of PItem;
  constructor Init;
  destructor Done; virtual;
  procedure Free;
  procedure Unlink(Item: PItem); // <- please, do not use it directly
  procedure Link(Item, NewParent: PItem); static; // Link(Item, nil) for Unlink
{$IFNDEF NO_IMBEDDED_JUNK}
type
  TLessThan = function (A, B: PItem): Boolean of object;
  procedure Exchange(A, B: Integer); inline;
  procedure QuickSort(LessThan: TLessThan; A, B: Integer);
  procedure Sort(LessThan: TLessThan); inline;
  procedure SortRecursively(LessThan: TLessThan);
  procedure FixSorting(LessThan: TLessThan);
type
  TApply = procedure (I: PItem) of object;
  TApplyN = procedure (I: PItem) is nested;
  TApplyInterruptable = function (I: PItem): Boolean of object;
  procedure ForEach(PreApply, PostApply: TApply); overload;
  procedure ForEachInverted(PreApply, PostApply: TApply); overload;
  procedure ForEachN(PreApply, PostApply: TApplyN); overload;
  procedure ForEachInvertedN(PreApply, PostApply: TApplyN); overload;
  function ForEach(PreApply, PostApply: TApplyInterruptable): Boolean; overload;
  function ForEachInverted(PreApply, PostApply: TApplyInterruptable): Boolean; overload;
{$ENDIF}
end;

implementation

constructor TImbeddedTree.Init;
begin
  // a constructor auto clears data inside object...
end;

destructor TImbeddedTree.Done;
var
  I: PItem;
begin
  for I in Sub do
    I.Free;
end;

procedure TImbeddedTree.Free;
begin
  if @Self <> nil then
    Done;
end;

procedure TImbeddedTree.Unlink(Item: PItem);
var
  I, C: Integer;
begin
  I := 0;
  C := 0;
  while I < Length(Sub) - C do begin
    if Sub[I] = Item then begin
      Inc(C);
    end else
      Inc(I);
    if (C > 0) and (I < Length(Sub) - C) then
      Sub[I] := Sub[I + C];
  end;
  SetLength(Sub, Length(Sub) - C);
  Item.ImbeddedTree.Parent := nil;
end;

procedure TImbeddedTree.Link(Item, NewParent: PItem); 
begin
  if Item.ImbeddedTree.Parent <> nil then
    Item.ImbeddedTree.Parent.ImbeddedTree.Unlink(Item);
  if NewParent = nil then
    Exit;
  Item.ImbeddedTree.Parent := NewParent;
  SetLength(NewParent.ImbeddedTree.Sub, Length(NewParent.ImbeddedTree.Sub) + 1);
  NewParent.ImbeddedTree.Sub[High(NewParent.ImbeddedTree.Sub)] := Item;
end;

{$IFNDEF NO_IMBEDDED_JUNK}
procedure TImbeddedTree.Exchange(A, B: Integer);
var
  Temp: PItem;
begin
  Temp := Sub[A];
  Sub[A] := Sub[B];
  Sub[B] := Temp;
end;

procedure TImbeddedTree.QuickSort(LessThan: TLessThan; A, B: Integer);
var
  L, R, M: Integer;
  Temp: PItem;
begin
  if A >= B then
    Exit;
  L := A;
  R := B;
  M := (A + B) div 2;
  while L < R do begin
    while LessThan(Sub[L], Sub[M]) do Inc(L);
    while LessThan(Sub[M], Sub[R]) do Dec(R);
    Exchange(L, R);
    if L = M then begin
      M := R;
    end else if R = M then
      M := L;
  end;
  QuickSort(LessThan, A, M - 1);
  QuickSort(LessThan, M + 1, B);
end;

procedure TImbeddedTree.Sort(LessThan: TLessThan);
begin
  QuickSort(LessThan, 0, High(Sub));
end;

procedure TImbeddedTree.SortRecursively(LessThan: TLessThan);
var
  I: PItem;
begin
  for I in Sub do
    I.ImbeddedTree.SortRecursively(LessThan);
  Sort(LessThan);
end;

procedure TImbeddedTree.FixSorting(LessThan: TLessThan);
var
  I, L, R, J: Integer;
  Temp: PItem;
begin
  // Usually sorting was broked after inserting an item,
  // we should use this heuristics...
  I := 1;
  while I < Length(Sub) do begin
    if LessThan(Sub[I - 1], Sub[I]) then begin
      Inc(I);
      continue;
    end;
    L := 0;
    R := I - 1;
    while L + 1 < R do begin
      J := (L + R) div 2;
      if LessThan(Sub[J], Sub[I]) then begin
        L := J;
      end else
        R := J;
    end;
    Temp := Sub[I];
    for J := I downto L + 1 do
      Sub[J] := Sub[J - 1];
    Sub[L] := Temp;
    Inc(I);
  end;
end;

procedure TImbeddedTree.ForEach(PreApply, PostApply: TApply);
var
  I: PItem;
begin
  for I in Sub do begin
    PreApply(I);
    I.ImbeddedTree.ForEach(PreApply, PostApply);
    PostApply(I);
  end;
end;

procedure TImbeddedTree.ForEachInverted(PreApply, PostApply: TApply);
var
  I: Integer;
begin
  for I := High(Sub) downto 0 do begin
    PreApply(Sub[I]);
    Sub[I].ImbeddedTree.ForEachInverted(PreApply, PostApply);
    PostApply(Sub[I]);
  end;
end;

procedure TImbeddedTree.ForEachN(PreApply, PostApply: TApplyN);
var
  I: PItem;
begin
  for I in Sub do begin
    PreApply(I);
    I.ImbeddedTree.ForEachN(PreApply, PostApply);
    PostApply(I);
  end;
end;

procedure TImbeddedTree.ForEachInvertedN(PreApply, PostApply: TApplyN);
var
  I: Integer;
begin
  for I := High(Sub) downto 0 do begin
    PreApply(Sub[I]);
    Sub[I].ImbeddedTree.ForEachInvertedN(PreApply, PostApply);
    PostApply(Sub[I]);
  end;
end;

function TImbeddedTree.ForEach(PreApply, PostApply: TApplyInterruptable): Boolean;
var
  I: PItem;
begin
  for I in Sub do begin
    if PreApply(I) then
      Exit(True);
    if I.ImbeddedTree.ForEach(PreApply, PostApply) then
      Exit(True);
    if PostApply(I) then
      Exit(True);
  end;
  Exit(False);
end;

function TImbeddedTree.ForEachInverted(PreApply, PostApply: TApplyInterruptable): Boolean;
var
  I: Integer;
begin
  for I := High(Sub) downto 0 do begin
    if PreApply(Sub[I]) then
      Exit(True);
    if Sub[I].ImbeddedTree.ForEachInverted(PreApply, PostApply) then
      Exit(True);
    if PostApply(Sub[I]) then
      Exit(True);
  end;
  Exit(False);
end;
{$ENDIF}

end.
