I just found another one, I made long time ago, I stopped to use it
because it is based on libavl and licence is GPL.
unit libavl;
interface
{$ALIGN ON}
{$MINENUMSIZE 4}
const
MAX_STACK = 32;
type
TBranchDir = (bLeft, bRight);
PIndexSlot = ^TIndexSlot;
TIndexSlot = record
FData: Pointer;
FPrev: PIndexSlot;
FNext: PIndexSlot;
end;
PIndexNode = ^TIndexNode;
TIndexNode = record
FBranch: array[TBranchDir] of PIndexNode;
FFirst: TIndexSlot;
FLast: PIndexSlot;
FBalance: Integer;
end;
TStackNodeArray = array[0..MAX_STACK - 1] of PIndexNode;
TIndexedList = class
private
FRoot: PIndexNode;
FCount: Cardinal;
FGeneration: Cardinal;
FCursor: PIndexNode;
FCursorSlot: PIndexSlot;
FStack: TStackNodeArray;
FStackSize: Cardinal;
FNeedResync: boolean;
procedure Resync;
function GetData: Pointer;
procedure DeleteItem(const p: PIndexNode);
protected
function doCompare(const item1, item2: Pointer): Integer; virtual;
procedure doDelete(const item: Pointer); virtual;
public
constructor Create; virtual;
destructor Destroy; override;
procedure Clear;
function Add(const item: Pointer; unique: boolean): Pointer;
function Delete(const item: Pointer): Pointer;
function Find(const item: Pointer): Pointer;
function First: Pointer;
function Last: Pointer;
function Prior: Pointer;
function Next: Pointer;
function FindNext: Pointer;
function FindPrior: Pointer;
property Data: Pointer read GetData;
property Count: Cardinal read FCount;
end;
implementation
uses SysUtils;
type
TStackDirArray = array[0..MAX_STACK - 1] of TBranchDir;
{ TIndexdList }
function TIndexedList.doCompare(const item1, item2: Pointer): Integer;
begin
result := 0;
end;
procedure TIndexedList.doDelete(const item: Pointer);
begin
end;
procedure TIndexedList.Resync;
var
node, i: PIndexNode;
begin
FNeedResync := False;
if (FCursor <> nil) then
begin
node := FCursor;
FStackSize := 0;
i := FRoot;
while i <> node do
begin
assert(FStackSize < MAX_STACK);
assert(i <> nil);
FStack[FStackSize] := i;
inc(FStackSize);
i := i.FBranch[TBranchDir(
doCompare(node.FFirst.FData, i.FFirst.FData) > 0)];
end;
end;
end;
function TIndexedList.GetData: Pointer;
begin
if FCursorSlot <> nil then
Result := FCursorSlot.FData
else
Result := nil;
end;
constructor TIndexedList.Create;
begin
FRoot := nil;
FCursor := nil;
FCursorSlot := nil;
FCount := 0;
FGeneration := 0;
FStackSize := 0;
FNeedResync := False;
end;
function TIndexedList.Delete(const item: Pointer): Pointer;
var
na: TStackNodeArray;
da: TStackDirArray;
k, j, comp: Integer;
i: Pointer;
dir: TBranchDir;
p1, p2, p3, p4, p5, p6: PIndexNode;
begin
assert(item <> nil);
p3 := nil;
k := 0;
p1 := @FRoot;
comp := -1;
while comp <> 0 do
begin
dir := TBranchDir(comp > 0);
na[k] := p1;
da[k] := dir;
inc(k);
p1 := p1.FBranch[dir];
if (p1 = nil) then
begin
Result := nil;
exit;
end;
comp := doCompare(item, p1.FFirst.FData);
end;
i := p1.FFirst.FData;
if (p1.FBranch[bRight] = nil) then
na[k - 1].FBranch[da[k - 1]] := p1.FBranch[bLeft]
else
begin
p2 := p1.FBranch[bRight];
if (p2.FBranch[bLeft] = nil) then
begin
p2.FBranch[bLeft] := p1.FBranch[bLeft];
p2.FBalance := p1.FBalance;
na[k - 1].FBranch[da[k - 1]] := p2;
da[k] := bRight;
na[k] := p2;
inc(k);
end
else
begin
j := k;
inc(k);
while True do
begin
da[k] := bLeft;
na[k] := p2;
inc(k);
p3 := p2.FBranch[bLeft];
if (p3.FBranch[bLeft] = nil) then
break;
p2 := p3;
end;
p3.FBranch[bLeft] := p1.FBranch[bLeft];
p2.FBranch[bLeft] := p3.FBranch[bRight];
p3.FBranch[bRight] := p1.FBranch[bRight];
p3.FBalance := p1.FBalance;
na[j - 1].FBranch[da[j - 1]] := p3;
da[j] := bRight;
na[j] := p3;
end;
end;
DeleteItem(p1);
assert(k > 0);
dec(k);
while (k > 0) do
begin
p4 := na[k];
if (da[k] = bLeft) then
begin
inc(p4.FBalance);
if (p4.FBalance = 1) then
break
else
if (p4.FBalance = 2) then
begin
p5 := p4.FBranch[bRight];
if (p5.FBalance = -1) then
begin
assert(p5.FBalance = -1);
p6 := p5.FBranch[bLeft];
p5.FBranch[bLeft] := p6.FBranch[bRight];
p6.FBranch[bRight] := p5;
p4.FBranch[bRight] := p6.FBranch[bLeft];
p6.FBranch[bLeft] := p4;
if (p6.FBalance = 1) then
begin
p5.FBalance := 0;
p4.FBalance := -1;
end
else
if (p6.FBalance = 0) then
begin
p5.FBalance := 0;
p4.FBalance := 0;
end
else
begin
p5.FBalance := 1;
p4.FBalance := 0;
end;
p6.FBalance := 0;
na[k - 1].FBranch[da[k - 1]] := p6;
end
else
begin
p4.FBranch[bRight] := p5.FBranch[bLeft];
p5.FBranch[bLeft] := p4;
na[k - 1].FBranch[da[k - 1]] := p5;
if (p5.FBalance = 0) then
begin
p5.FBalance := -1;
p4.FBalance := 1;
break;
end
else
begin
p5.FBalance := 0;
p4.FBalance := 0;
end;
end;
end;
end
else
begin
dec(p4.FBalance);
if (p4.FBalance = -1) then
break
else
if (p4.FBalance = -2) then
begin
p5 := p4.FBranch[bLeft];
if (p5.FBalance = 1) then
begin
assert(p5.FBalance = 1);
p6 := p5.FBranch[bRight];
p5.FBranch[bRight] := p6.FBranch[bLeft];
p6.FBranch[bLeft] := p5;
p4.FBranch[bLeft] := p6.FBranch[bRight];
p6.FBranch[bRight] := p4;
if (p6.FBalance = -1) then
begin
p5.FBalance := 0;
p4.FBalance := 1;
end
else
if (p6.FBalance = 0) then
begin
p5.FBalance := 0;
p4.FBalance := 0;
end
else
begin
p5.FBalance := -1;
p4.FBalance := 0;
end;
p6.FBalance := 0;
na[k - 1].FBranch[da[k - 1]] := p6;
end
else
begin
p4.FBranch[bLeft] := p5.FBranch[bRight];
p5.FBranch[bRight] := p4;
na[k - 1].FBranch[da[k - 1]] := p5;
if (p5.FBalance = 0) then
begin
p5.FBalance := 1;
p4.FBalance := -1;
break;
end
else
begin
p5.FBalance := 0;
p4.FBalance := 0;
end;
end;
end;
end;
dec(k);
end;
dec(FCount);
inc(FGeneration);
Result := i;
end;
destructor TIndexedList.Destroy;
begin
Clear;
inherited;
end;
function TIndexedList.First: Pointer;
var
p: PIndexNode;
begin
FStackSize := 0;
FNeedResync := False;
p := FRoot;
if (p <> nil) then
while (p.FBranch[bLeft] <> nil) do
begin
assert(FStackSize < MAX_STACK);
FStack[FStackSize] := p;
inc(FStackSize);
p := p.FBranch[bLeft];
end;
FCursor := p;
if p <> nil then
begin
FCursorSlot := @p.FFirst;
Result := FCursorSlot.FData
end
else
begin
FCursorSlot := nil;
Result := nil;
end;
end;
function TIndexedList.Last: Pointer;
var
p: PIndexNode;
begin
FStackSize := 0;
FNeedResync := False;
p := FRoot;
if (p <> nil) then
while (p.FBranch[bRight] <> nil) do
begin
assert(FStackSize < MAX_STACK);
FStack[FStackSize] := p;
inc(FStackSize);
p := p.FBranch[bRight];
end;
FCursor := p;
if p <> nil then
begin
FCursorSlot := FCursor.FLast;
Result := FCursorSlot.FData
end
else
begin
FCursorSlot := nil;
Result := nil;
end;
end;
function TIndexedList.Find(const item: Pointer): Pointer;
var
p, q: PIndexNode;
comp: integer;
begin
assert(item <> nil);
FStackSize := 0;
FNeedResync := False;
p := FRoot;
q := nil;
while p <> nil do
begin
comp := doCompare(item, p.FFirst.FData);
if (comp < 0) then
q := p.FBranch[bLeft]
else
if (comp > 0) then
q := p.FBranch[bRight]
else
begin
FCursor := p;
FCursorSlot := @p.FFirst;
Result := FCursorSlot.FData;
exit;
end;
assert(FStackSize < MAX_STACK);
FStack[FStackSize] := p;
inc(FStackSize);
p := q;
end;
FStackSize := 0;
FCursor := nil;
FCursorSlot := nil;
Result := nil;
end;
function TIndexedList.Add(const item: Pointer; unique: boolean): Pointer;
var
da: TStackDirArray;
p1, p2, p3, p4, p5, p6, p7: PIndexNode;
i, comp: Integer;
dir: TBranchDir;
begin
assert(item <> nil);
i := 0;
p7 := @FRoot;
p6 := FRoot;
dir := bLeft;
p3 := p7;
p2 := p6;
while p2 <> nil do
begin
comp := doCompare(item, p2.FFirst.FData);
if (comp = 0) then
begin
if unique then
begin
FCursor := p2;
FCursorSlot := @FCursor.FFirst;
result := FCursorSlot.FData;
doDelete(item);
end else
begin
FCursor := p2;
GetMem(FCursorSlot, SizeOf(TIndexSlot));
FCursorSlot.FData := item;
FCursorSlot.FPrev := FCursor.FLast;
FCursorSlot.FNext := nil;
FCursor.FLast.FNext := FCursorSlot;
FCursor.FLast := FCursorSlot;
FNeedResync := True;
Result := FCursorSlot.FData;
inc(FCount);
end;
exit;
end;
if (p2.FBalance <> 0) then
begin
p7 := p3;
p6 := p2;
i := 0;
end;
dir := TBranchDir(comp > 0);
da[i] := dir;
inc(i);
p3 := p2;
p2 := p2.FBranch[dir]
end;
GetMem(p1, sizeof(TIndexNode));
p3.FBranch[dir] := p1;
inc(FCount);
p1.FFirst.FData := item;
p1.FFirst.FNext := nil;
p1.FFirst.FPrev := nil;
p1.FLast := @p1.FFirst;
p1.FBranch[bLeft] := nil;
p1.FBranch[bRight] := nil;
p1.FBalance := 0;
if (p6 = nil) then
begin
FCursor := p1;
FCursorSlot := @p1.FFirst;
FNeedResync := True;
Result := FCursorSlot.FData;
exit;
end;
p2 := p6;
i := 0;
while p2 <> p1 do
begin
if (da[i] = bLeft) then
dec(p2.FBalance)
else
inc(p2.FBalance);
p2 := p2.FBranch[da[i]];
inc(i);
end;
if (p6.FBalance = -2) then
begin
p5 := p6.FBranch[bLeft];
if (p5.FBalance = -1) then
begin
p4 := p5;
p6.FBranch[bLeft] := p5.FBranch[bRight];
p5.FBranch[bRight] := p6;
p5.FBalance := 0;
p6.FBalance := 0;
end
else
begin
assert(p5.FBalance = 1);
p4 := p5.FBranch[bRight];
p5.FBranch[bRight] := p4.FBranch[bLeft];
p4.FBranch[bLeft] := p5;
p6.FBranch[bLeft] := p4.FBranch[bRight];
p4.FBranch[bRight] := p6;
if (p4.FBalance = -1) then
begin
p5.FBalance := 0;
p6.FBalance := 1;
end
else
if (p4.FBalance = 0) then
begin
p5.FBalance := 0;
p6.FBalance := 0;
end
else
begin
p5.FBalance := -1;
p6.FBalance := 0;
end;
p4.FBalance := 0;
end;
end
else
if (p6.FBalance = 2) then
begin
p5 := p6.FBranch[bRight];
if (p5.FBalance = 1) then
begin
p4 := p5;
p6.FBranch[bRight] := p5.FBranch[bLeft];
p5.FBranch[bLeft] := p6;
p5.FBalance := 0;
p6.FBalance := 0;
end
else
begin
assert(p5.FBalance = -1);
p4 := p5.FBranch[bLeft];
p5.FBranch[bLeft] := p4.FBranch[bRight];
p4.FBranch[bRight] := p5;
p6.FBranch[bRight] := p4.FBranch[bLeft];
p4.FBranch[bLeft] := p6;
if (p4.FBalance = 1) then
begin
p5.FBalance := 0;
p6.FBalance := -1;
end
else
if (p4.FBalance = 0) then
begin
p5.FBalance := 0;
p6.FBalance := 0;
end
else
begin
p5.FBalance := 1;
p6.FBalance := 0;
end;
p4.FBalance := 0;
end;
end
else
begin
FCursor := p1;
FCursorSlot := @p1.FFirst;
FNeedResync := True;
Result := FCursorSlot.FData;
exit;
end;
p7.FBranch[TBranchDir(p6 <> p7.FBranch[bLeft])] := p4;
inc(FGeneration);
FCursor := p1;
FCursorSlot := @p1.FFirst;
FNeedResync := True;
Result := FCursorSlot.FData;
end;
function TIndexedList.Next: Pointer;
var
p1, p2: PIndexNode;
begin
if FNeedResync then
Resync;
Result := FindNext;
if Result <> nil then
Exit;
p1 := FCursor;
if (p1 = nil) then
begin
Result := First;
exit;
end
else
if (p1.FBranch[bRight] <> nil) then
begin
assert(FStackSize < MAX_STACK);
FStack[FStackSize] := p1;
inc(FStackSize);
p1 := p1.FBranch[bRight];
while (p1.FBranch[bLeft] <> nil) do
begin
assert(FStackSize < MAX_STACK);
FStack[FStackSize] := p1;
inc(FStackSize);
p1 := p1.FBranch[bLeft];
end;
end
else
repeat
if (FStackSize = 0) then
begin
FCursor := nil;
FCursorSlot := nil;
Result := nil;
exit;
end;
p2 := p1;
dec(FStackSize);
p1 := FStack[FStackSize];
until (p2 <> p1.FBranch[bRight]);
FCursor := p1;
FCursorSlot := @p1.FFirst;
Result := FCursorSlot.FData;
end;
function TIndexedList.Prior: Pointer;
var
p1, p2: PIndexNode;
begin
if FNeedResync then
Resync;
Result := FindPrior;
if Result <> nil then
Exit;
p1 := FCursor;
if (p1 = nil) then
begin
Result := Last;
exit;
end
else
if (p1.FBranch[bLeft] <> nil) then
begin
assert(FStackSize < MAX_STACK);
FStack[FStackSize] := p1;
inc(FStackSize);
p1 := p1.FBranch[bLeft];
while (p1.FBranch[bRight] <> nil) do
begin
assert(FStackSize < MAX_STACK);
FStack[FStackSize] := p1;
inc(FStackSize);
p1 := p1.FBranch[bRight];
end;
end
else
repeat
if (FStackSize = 0) then
begin
FCursor := nil;
FCursorSlot := nil;
Result := nil;
exit;
end;
p2 := p1;
dec(FStackSize);
p1 := FStack[FStackSize];
until (p2 <> p1.FBranch[bLeft]);
FCursor := p1;
FCursorSlot := @p1.FFirst;
Result := FCursorSlot.FData;
end;
procedure TIndexedList.Clear;
var
p1, p2: PIndexNode;
begin
p1 := FRoot;
while p1 <> nil do
begin
if (p1.FBranch[bLeft] = nil) then
begin
p2 := p1.FBranch[bRight];
DeleteItem(p1);
end
else
begin
p2 := p1.FBranch[bLeft];
p1.FBranch[bLeft] := p2.FBranch[bRight];
p2.FBranch[bRight] := p1;
end;
p1 := p2;
end;
FRoot := nil;
FCount := 0;
FGeneration := 0;
FCursor := nil;
FCursorSlot := nil;
FStackSize := 0;
FNeedResync := False;
end;
procedure TIndexedList.DeleteItem(const p: PIndexNode);
var
p1, p2: PIndexSlot;
begin
doDelete(p.FFirst.FData);
p1 := p.FFirst.FNext;
while p1 <> nil do
begin
if p1.FData <> nil then
doDelete(p1.FData);
p2 := p1;
p1 := p2.FNext;
FreeMem(p2);
dec(FCount);
end;
FreeMem(p);
end;
function TIndexedList.FindNext: Pointer;
begin
if FCursorSlot <> nil then
begin
FCursorSlot := FCursorSlot.FNext;
if FCursorSlot <> nil then
Result := FCursorSlot.FData else
Result := nil;
end else
Result := nil
end;
function TIndexedList.FindPrior: Pointer;
begin
if FCursorSlot <> nil then
begin
FCursorSlot := FCursorSlot.FPrev;
if FCursorSlot <> nil then
Result := FCursorSlot.FData else
Result := nil;
end else
Result := nil
end;
end.
_______________________________________________
fpc-devel maillist - fpc-devel@lists.freepascal.org
http://lists.freepascal.org/mailman/listinfo/fpc-devel
