uList
Post date: Jul 17, 2010 1:14:58 AM
uList contains definitions of a reduced version of the standard delphi TList and TThreadList classes.
{##########################################
# #
# uList #
# #
# Author: testest #
# Date: 2010-07-08 #
# Version: 0.1 #
# #
##########################################}
unit uList;
interface
uses Windows;
const
MaxListSize = 134217727;
type
TListAssignOp = (laCopy, laAnd, laOr, laXor, laSrcUnique, laDestUnique);
TListSortCompare = function(Item1, Item2: Pointer): Integer;
TPointerList = array[0..MaxListSize-1] of Pointer;
PPointerList = ^TPointerList;
TPointerArray = array of Pointer;
TList = class
private
FList: TPointerArray;
FPList: PPointerList;
FCount: Integer;
FCapacity: Integer;
procedure SetCapacity(Value: Integer);
function ValidIndex(Index: Integer): Boolean;
function GetItem(Index: Integer): Pointer;
procedure SetItem(Index: Integer; Item: Pointer);
procedure MoveBlock(Index1, Index2, Dir: Integer);
function Merge(List1, List2: TPointerArray; Compare: TListSortCompare): TPointerArray;
function MergeSort(List: TPointerArray; Compare: TListSortCompare): TPointerArray;
protected
function Compare(Item1, Item2: Pointer): Boolean;
public
constructor Create;
function Add(Item: Pointer): Integer;
procedure Assign(ListA: TList; AOperator: TListAssignOp = laCopy; ListB: TList = nil);
procedure Clear;
procedure Delete(Index: Integer);
destructor Destroy; override;
procedure Exchange(Index1, Index2: Integer);
function Expand: TList;
function Extract(Item: Pointer): Pointer;
function First: Pointer;
function IndexOf(Item: Pointer): Integer;
procedure Insert(Index: Integer; Item: Pointer);
function Last: Pointer;
procedure Move(CurIndex, NewIndex: Integer);
procedure Pack;
function Remove(Item: Pointer): Integer;
procedure Sort(Compare: TListSortCompare);
property Capacity: Integer read FCapacity write SetCapacity;
property Count: Integer read FCount;
property Items[Index: Integer]: Pointer read GetItem write SetItem; default;
property List: PPointerList read FPList;
end;
TDuplicates = (dupIgnore, dupAccept, dupError);
TThreadList = class
private
FDuplicates: TDuplicates;
FList: TList;
FLock: TRTLCriticalSection;
public
procedure Add(Item: Pointer);
procedure Clear;
constructor Create;
destructor Destroy; override;
function LockList: TList;
procedure Remove(Item: Pointer);
procedure UnlockList;
property Duplicates: TDuplicates read FDuplicates write FDuplicates;
end;
implementation
constructor TList.Create;
begin
inherited Create;
Clear;
FPList := @FList;
end;
procedure TList.SetCapacity(Value: Integer);
begin
if Value <> FCapacity then
begin
SetLength(FList, Value);
FCapacity := Value;
end;
end;
function TList.ValidIndex(Index: Integer): Boolean;
begin
Result := (Index >= 0) and (Index < FCount);
end;
function TList.GetItem(Index: Integer): Pointer;
begin
if ValidIndex(Index) then
Result := FList[Index]
else
Result := nil;
end;
procedure TList.SetItem(Index: Integer; Item: Pointer);
begin
if ValidIndex(Index) then
FList[Index] := Item;
end;
procedure TList.MoveBlock(Index1, Index2, Dir: Integer);
var
I: Integer;
begin
if Dir > 0 then
for I := Index2 downto Index1 do
FList[I + 1] := FList[I]
else if Dir < 0 then
for I := Index1 to Index2 do
FList[I - 1] := FList[I];
end;
function TList.Compare(Item1, Item2: Pointer): Boolean;
begin
Result := Item1 = Item2;
end;
function TList.Add(Item: Pointer): Integer;
begin
Expand;
FList[FCount] := Item;
Result := FCount;
Inc(FCount);
end;
procedure TList.Assign(ListA: TList; AOperator: TListAssignOp = laCopy; ListB: TList = nil);
var
I: Integer;
begin
if Assigned(ListB) then
begin
Assign(ListA);
Assign(ListB, AOperator);
end
else case AOperator of
laCopy: begin
FList := ListA.FList;
FCapacity := ListA.Capacity;
FCount := ListA.FCount;
end;
laAnd:
for I := FCount - 1 downto 0 do
if ListA.IndexOf(FList[I]) = -1 then
Delete(I);
laOr:
for I := 0 to ListA.FCount - 1 do
if IndexOf(ListA.FList[I]) = -1 then
Add(ListA.FList[I]);
laXor:
for I := 0 to ListA.FCount - 1 do
if Remove(ListA.FList[I]) = -1 then
Add(ListA.FList[I]);
laSrcUnique: begin
Assign(ListA, laAnd);
Assign(ListA, laXor);
end;
laDestUnique: begin
Assign(ListA, laOr);
Assign(ListA, laAnd);
end;
end;
end;
procedure TList.Clear;
begin
FCount := 0;
FCapacity := 0;
SetLength(FList, 0);
end;
procedure TList.Delete(Index: Integer);
begin
if ValidIndex(Index) then
begin
Dec(FCount);
if Index < FCount then
MoveBlock(Index + 1, FCount, -1);
end;
end;
procedure TList.Exchange(Index1, Index2: Integer);
var
Tmp: Pointer;
begin
if ValidIndex(Index1) and ValidIndex(Index2) then
begin
Tmp := FList[Index1];
FList[Index1] := FList[Index2];
FList[Index2] := Tmp;
end;
end;
function TList.Expand: TList;
begin
while FCount >= FCapacity do
case FCapacity of
0..4: SetCapacity(FCapacity + 4);
5..8: SetCapacity(FCapacity + 8);
else SetCapacity(FCapacity + 16);
end;
Result := Self;
end;
function TList.Extract(Item: Pointer): Pointer;
var
Index: Integer;
begin
Index := IndexOf(Item);
Result := GetItem(Index);
Delete(Index);
end;
function TList.First: Pointer;
begin
Result := GetItem(0);
end;
function TList.IndexOf(Item: Pointer): Integer;
begin
for Result := 0 to FCount - 1 do
if Compare(FList[Result], Item) then
Exit;
Result := -1;
end;
procedure TList.Insert(Index: Integer; Item: Pointer);
begin
if ValidIndex(Index) then
begin
Expand;
MoveBlock(Index, FCount - 1, 1);
Inc(FCount);
FList[Index] := Item;
end;
end;
function TList.Last: Pointer;
begin
Result := GetItem(FCount - 1);
end;
procedure TList.Move(CurIndex, NewIndex: Integer);
var
Tmp: Pointer;
begin
if ValidIndex(CurIndex) and ValidIndex(NewIndex) and (CurIndex <> NewIndex) then
begin
Tmp := FList[CurIndex];
if CurIndex < NewIndex then
MoveBlock(CurIndex + 1, NewIndex, -1)
else
MoveBlock(NewIndex, CurIndex - 1, 1);
FList[NewIndex] := Tmp;
end;
end;
procedure TList.Pack;
var
I: Integer;
begin
for I := FCount - 1 downto 0 do
if FList[I] = nil then
Delete(I);
end;
function TList.Remove(Item: Pointer): Integer;
begin
Result := IndexOf(Item);
Delete(Result);
end;
function TList.Merge(List1, List2: TPointerArray; Compare: TListSortCompare): TPointerArray;
var
I, J, K, L, R: Integer;
function PostInc(var X: Integer): Integer;
begin
Result := X;
Inc(X);
end;
begin
I := 0;
J := 0;
R := 0;
K := Length(List1);
L := Length(List2);
SetLength(Result, K + L);
while (I < K) and (J < L) do
if Compare(List1[I], List2[J]) >= 0 then
Result[PostInc(R)] := List1[PostInc(I)]
else
Result[PostInc(R)] := List2[PostInc(J)];
while I < K do
Result[PostInc(R)] := List1[PostInc(I)];
while J < L do
Result[PostInc(R)] := List2[PostInc(J)];
end;
function TList.MergeSort(List: TPointerArray; Compare: TListSortCompare): TPointerArray;
var
L, P: Integer;
begin
L := Length(List);
if L = 1 then
Result := List
else
begin
P := L div 2;
Result := Merge(MergeSort(Copy(List, 0, P), Compare),
MergeSort(Copy(List, P, L), Compare), Compare);
end;
end;
procedure TList.Sort(Compare: TListSortCompare);
var
Tmp: Integer;
begin
if FCount > 1 then
begin
Tmp := FCapacity;
FList := MergeSort(Copy(FList, 0, FCount), Compare);
FCapacity := FCount;
SetCapacity(Tmp);
end;
end;
destructor TList.Destroy;
begin
Clear;
inherited Destroy;
end;
procedure TThreadList.Add(Item: Pointer);
begin
with LockList do try
if (Duplicates = dupAccept) or (IndexOf(Item) = -1) then
Add(Item);
finally
UnlockList;
end;
end;
procedure TThreadList.Clear;
begin
with LockList do try
Clear;
finally
UnlockList;
end;
end;
constructor TThreadList.Create;
begin
inherited Create;
InitializeCriticalSection(FLock);
FList := TList.Create;
FDuplicates := dupIgnore;
end;
destructor TThreadList.Destroy;
begin
FList.Free;
DeleteCriticalSection(FLock);
inherited Destroy;
end;
function TThreadList.LockList: TList;
begin
EnterCriticalSection(FLock);
Result := FList;
end;
procedure TThreadList.Remove(Item: Pointer);
begin
with LockList do try
Remove(Item);
finally
UnlockList;
end;
end;
procedure TThreadList.UnlockList;
begin
LeaveCriticalSection(FLock);
end;
end.