{ +-------------------------------------------------------------+ }
{ | | }
{ | GM-Software | }
{ | =========== | }
{ | | }
{ | Project: All Projects | }
{ | | }
{ | Description: Collections/Containers, ArrayLists, AVL- | }
{ | Trees and HashTables with common interfaces. | }
{ | All Collections are thread safe! | }
{ | | }
{ | Copyright (C) - Gerrit Moeller, 2011. | }
{ | | }
{ | Dstributed under GM-Software license. | }
{ | | }
{ | See: http://www.gm-software.de | }
{ | | }
{ +-------------------------------------------------------------+ }
{$INCLUDE GMCompilerSettings.inc}
{.$DEFINE STANDALONE_COLLECTIONS} // <- avoid using GMIntf and GMCommon units
unit GMCollections;
interface
uses Windows {$IFNDEF STANDALONE_COLLECTIONS}, GMIntf{$ENDIF};
const
cMaxPtrArraySize = High(LongInt) div SizeOf(Pointer); //SizeOf(TObject);
cMaxIntArraySize = High(LongInt) div SizeOf(LongInt);
{ ------------------------------------------------------------------- }
{ ---- Re-defined types when not using GMIntf and GMCommon units ---- }
{ ------------------------------------------------------------------- }
{$IFDEF STANDALONE_COLLECTIONS}
const
cInvalidItemIdx = Low(LongInt); // -1;
type
TGMCompareResult = (crALessThanB, crAEqualToB, crAGreaterThanB);
TGMHashCode = LongInt;
{$IFNDEF FPC}
PtrInt = LongInt;
PtrUInt = LongWord;
{$ENDIF}
IGMCriticalSection = interface(IUnknown)
['{278BDF06-1387-4181-A83D-8DDF4E18CE03}']
procedure EnterCriticalSection; stdcall;
procedure LeaveCriticalSection; stdcall;
//function TryEnterCriticalSection: Boolean; stdcall;
end;
IGMGetCount = interface(IUnknown)
['{93880081-2684-11d5-AB38-000021DCAD19}']
function GetCount: LongInt; stdcall;
property Count: LongInt read GetCount;
end;
IGMLoadStoreData = interface(IUnknown)
['{D8D48DE1-AE80-4132-AE40-ECA66F9256C6}']
procedure LoadData(const Source: IUnknown); stdcall;
procedure StoreData(const Dest: IUnknown); stdcall;
end;
IGMGetIntfByPosition = interface(IUnknown)
['{4694A884-24F6-11d5-AB38-000021DCAD19}']
function GetIntfByPosition(const Position: LongInt; const IID: TGUID; out Intf): HResult; stdcall;
end;
IGMMapIntegerOnInteger = interface(IUnknown)
['{1BC6F7EB-C230-48ba-B383-B332D555DA6F}']
function MapIntegerOnInteger(const MapValue: LongInt): LongInt; stdcall;
end;
IGMExecuteOperation = interface(IUnknown)
['{DCC23FA6-D77E-44c9-95BA-DFAA264451FD}']
function ExecuteOperation(const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; stdcall;
end;
IGMHashCode = interface(IUnknown)
['{9C61B58B-41DF-4695-9716-AC4A343DC2DB}']
function HashCode: TGMHashCode;
end;
TGMRefLifeObject = class(TObject, IUnknown) // IGMObjInfo, IGMCreateCopyQI
protected
FRefLifeTime: Boolean;
FRefCount: LongInt;
public
constructor Create(const ARefLifeTime: Boolean = False); virtual;
procedure AfterConstruction; override;
procedure BeforeDestruction; override;
// destructor Destroy; override;
procedure OnFinalRelease; virtual;
// IGMObjInfo
// function GetClassName: PChar;
// function GetClassType: TClass;
// function GetInstance: TObject;
// function GetTypeInfo: PTypeInfo;
// IUnknown
function QueryInterface({$IFDEF FPC}constref{$ELSE}const{$ENDIF} IID: TGUID; out Intf): HResult; virtual; stdcall;
function _AddRef: LongInt; virtual; stdcall;
function _Release: LongInt; virtual; stdcall;
// IGMCreateCopyQI
// function CreateCopyQI(const IID: TGUID; out Intf): HResult; virtual; stdcall;
property RefCount: LongInt read FRefCount;
property RefLifeTime: Boolean read FRefLifeTime write FRefLifeTime;
end;
TGMCriticalSection = class(TGMRefLifeObject, IGMCriticalSection)
protected
FCriticalSection: TRTLCriticalSection;
public
constructor Create(const ARefLifeTime: Boolean = True); override;
destructor Destroy; override;
procedure EnterCriticalSection; stdcall;
procedure LeaveCriticalSection; stdcall;
function TryEnterCriticalSection: Boolean; stdcall;
end;
TGMCriticalSectionLock = class(TGMRefLifeObject{, IGMLockCriticalSection})
protected
FCriticalSection: IGMCriticalSection;
public
constructor Create(const ACriticalSection: IUnknown; const ARefLifeTime: Boolean = True); reintroduce;
destructor Destroy; override;
end;
{$ENDIF}
{ ----------------------------- }
{ ---- Collection Gerneral ---- }
{ ----------------------------- }
type
TGMIntfCompareFunc = function (const EntryA, EntryB: IUnknown): TGMCompareResult;
TGMCountChangedProc = procedure (const Sender: TObject; const OldCount, NewCount: LongInt) of Object;
//TGMObjVisitFunc = function (const VisitedObj: TObject): Boolean;
IGMIterator = interface(IUnknown)
['{A78717F7-120B-4704-BCA3-2C9E8706CE48}']
function NextEntry(out AEntry): Boolean;
procedure Reset;
end;
IGMCreateIterator = interface(IGMGetCount) // IUnknown
['{E57F2FDF-8660-448E-968D-C7248A20EA24}']
function CreateIterator(const AReverse: Boolean = False; const AConcurrentThreadLock: Boolean = False): IGMIterator;
end;
IGMCollection = interface(IGMCreateIterator)
['{468D1111-7D28-4195-9C44-13065516B0F4}']
procedure SetCompareFunc(const Value: TGMIntfCompareFunc);
//function GetCount: LongInt; stdcall;
function IsEmpty: Boolean;
procedure SetOnAfterCountChanged(const Value: TGMCountChangedProc);
procedure Clear(const ANotify: Boolean = True);
function Find(const AKey: IUnknown; out AEntry): Boolean;
function FindNearest(const AKey: IUnknown; out AEntry): Boolean;
function RemoveByKey(const AKey: IUnknown): Boolean;
function IsValidIndex(const AIndex: LongInt): Boolean;
property Count: LongInt read GetCount;
property CompareItemFunc: TGMIntfCompareFunc write SetCompareFunc;
property OnAfterCountChanged: TGMCountChangedProc write SetOnAfterCountChanged;
end;
IGMObjCollection = interface(IGMCollection)
['{979CCBB6-587C-49FD-A98A-0D3DF11789E0}']
function First: TObject;
function Last: TObject;
function Add(const ANewEntry: TObject; const AReplaceIfExists: Boolean = False): TObject;
function RemoveByInstance(const AObj: TObject): Boolean;
end;
IGMIntfCollection = interface(IGMCollection)
['{3DEA459B-0A78-4C91-981E-2E6F4D5C5D9F}']
function First: IUnknown;
function Last: IUnknown;
function Add(const ANewEntry: IUnknown; const AReplaceIfExists: Boolean = False): IUnknown;
function RemoveByInstance(const AIntf: IUnknown): Boolean;
end;
TGMIteratorBase = class(TGMRefLifeObject, IGMIterator)
protected
FCollection: TObject;
FReverse: Boolean;
FSyncLock: IUnknown;
public
constructor Create(const ACollection: TObject; const AReverse: Boolean = False; const AConcurrentThreadLock: Boolean = False; const ARefLifeTime: Boolean = True); reintroduce;
function NextEntry(out AEntry): Boolean; virtual; abstract;
procedure Reset; virtual; abstract;
end;
TGMCollectionBase = class(TGMRefLifeObject, IGMCriticalSection, IGMCollection, IGMGetCount, IGMCreateIterator)
protected
FCount: LongInt;
FCompareFunc: TGMIntfCompareFunc;
FCriticalSection: IGMCriticalSection;
FAcceptDuplicates: Boolean;
FOnAfterCountChanged: TGMCountChangedProc;
function CompareEntries(const EntryA, EntryB: IUnknown): TGMCompareResult;
procedure SetCompareFunc(const AValue: TGMIntfCompareFunc); virtual;
procedure AfterCompareFuncChanged; virtual;
procedure NotifyAfterCountChanged(const OldCount, NewCount: LongInt);
procedure SetOnAfterCountChanged(const Value: TGMCountChangedProc);
public
constructor Create(const AAcceptDuplicates: Boolean = True;
const ACompareFunc: TGMIntfCompareFunc = nil;
const ARefLifeTime: Boolean = False); reintroduce; overload; virtual;
destructor Destroy; override;
function GetCount: LongInt; virtual; stdcall;
function IsEmpty: Boolean; virtual;
function IsValidIndex(const AIndex: LongInt): Boolean; virtual;
procedure Clear(const ANotify: Boolean = True); virtual; abstract;
function Find(const AKey: IUnknown; out AEntry): Boolean; virtual; abstract;
function FindNearest(const AKey: IUnknown; out AEntry): Boolean; virtual; abstract;
function RemoveByKey(const AKey: IUnknown): Boolean; virtual; abstract;
function CreateIterator(const AReverse: Boolean = False; const AConcurrentThreadLock: Boolean = False): IGMIterator; virtual; abstract;
property Count: LongInt read GetCount;
property CompareItemFunc: TGMIntfCompareFunc read FCompareFunc write SetCompareFunc;
property CriticalSection: IGMCriticalSection read FCriticalSection implements IGMCriticalSection;
property OnAfterCountChanged: TGMCountChangedProc read FOnAfterCountChanged write SetOnAfterCountChanged;
end;
{ -------------------- }
{ ---- Arraylists ---- }
{ -------------------- }
//
// NOTE: Indexing of all list implementations is zero based!
//
//IGMArrayListBase = interface(IGMCollection)
// ['{313F4327-7EF8-440d-9B12-2A8EF8240A26}']
// function GetSorted: Boolean;
// procedure SetSorted(const Value: Boolean);
//
// procedure RemoveByIdx(const Index: LongInt; DelCount: LongInt = 1);
// procedure Rotate(const Delta: LongInt; const StartPos: LongInt = 0);
// procedure Exchange(const Index1, Index2: LongInt);
// procedure Reverse;
// procedure Sort;
//
// function IndexOf(const AKey: IUnknown): LongInt;
// function IndexOfNearest(const AKey: IUnknown): LongInt;
//
// property Sorted: Boolean read GetSorted write SetSorted;
//end;
PPointerList = ^TPointerList;
TPointerList = array[0 .. cMaxPtrArraySize-1] of Pointer;
TGMArrayListBase = class(TGMCollectionBase, IGMExecuteOperation, IGMGetIntfByPosition, IGMLoadStoreData) // IGMArrayListBase,
protected
FEntries: PPointerList;
FCapacity: LongInt;
FSorted: Boolean;
FFreeEntries: Boolean;
function GetSorted: Boolean;
procedure SetSorted(const Value: Boolean);
procedure SetCapacity(const NewCapacity: LongInt);
function IndexOfPointer(const Ptr: Pointer): LongInt;
function IsDuplicate(const AKey: IUnknown; const Index: LongInt): Boolean;
procedure InsertPointer(const AInstance: Pointer; const Index: LongInt);
function EntryAsIntf(const Index: LongInt): IUnknown; virtual; abstract;
procedure FreePointer(var Item: Pointer); virtual; abstract;
procedure AfterCompareFuncChanged; override;
procedure NotifyAfterAddItem(const AItem: Pointer; const AIndex: LongInt); virtual; abstract;
procedure NotifyBeforeRemoveItem(const AItem: Pointer; const AIndex: LongInt); virtual; abstract;
procedure CheckSorted;
procedure CheckUnsorted;
public
constructor Create(const AAcceptDuplicates: Boolean = True;
const ASorted: Boolean = False;
const ACompareFunc: TGMIntfCompareFunc = nil;
const ARefLifeTime: Boolean = False); reintroduce;
function ExecuteOperation(const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; virtual; stdcall;
function GetIntfByPosition(const Position: LongInt; const IID: TGUID; out Intf): HResult; virtual; stdcall;
procedure Clear(const ANotify: Boolean = True); override;
procedure Sort; virtual;
//procedure Pack; virtual;
{$IFDEF STANDALONE_COLLECTIONS}
procedure LoadData(const Source: IUnknown); stdcall;
procedure StoreData(const Dest: IUnknown); stdcall;
{$ELSE}
procedure LoadData(const Source: IGMValueStorage); stdcall;
procedure StoreData(const Dest: IGMValueStorage); stdcall;
{$ENDIF}
procedure RemoveByIdx(const Index: LongInt; DelCount: LongInt = 1); virtual;
function RemoveByKey(const AKey: IUnknown): Boolean; override;
function InsertIdx(const AKey: IUnknown): LongInt; virtual;
function IndexOf(const AKey: IUnknown): LongInt; virtual;
function IndexOfNearest(const AKey: IUnknown): LongInt; virtual;
function Find(const AKey: IUnknown; out AEntry): Boolean; override;
function FindNearest(const AKey: IUnknown; out AEntry): Boolean; override;
procedure Rotate(const Delta: LongInt; const StartPos: LongInt = 0);
procedure Exchange(const Index1, Index2: LongInt);
procedure Move(const SourceIdx, DestIdx: LongInt);
procedure Reverse;
property Capacity: LongInt read FCapacity {write SetCapacity};
property Sorted: Boolean read GetSorted write SetSorted;
end;
TGMArrayListBaseIterator = class(TGMIteratorBase)
protected
FCurrentIdx: LongInt;
procedure AssignOutEntry(out AEntry); virtual; abstract;
public
procedure Reset; override;
function NextEntry(out AEntry): Boolean; override;
end;
TGMObjItemAddRemoveProc = procedure(const Sender, Entry: TObject; const AIndex: LongInt) of object;
IGMObjArrayList = interface(IGMObjCollection) // IGMArrayListBase
['{E83BD4DC-E50E-4fc3-9161-9F5829BC6C92}']
function GetItem(const Index: LongInt): TObject;
procedure SetItem(const Index: LongInt; const Value: TObject);
procedure SetOnAfterAddItem(const Value: TGMObjItemAddRemoveProc);
procedure SetOnBeforeRemoveItem(const Value: TGMObjItemAddRemoveProc);
//function Add(const AObj: TObject): TObject;
function AddIdx(const AObj: TObject; const AReplaceIfExists: Boolean = False): LongInt;
function Insert(const AObj: TObject; const Index: LongInt; const AReplaceIfExists: Boolean = False): TObject;
//function First: TObject;
//function Last: TObject;
function IndexOfObj(const AObj: TObject): LongInt;
//function FindObj(const AObj: TObject; var Index: LongInt): Boolean;
property Items[const Idx: LongInt]: TObject read GetItem write SetItem; default;
property OnAfterAddItem: TGMObjItemAddRemoveProc write SetOnAfterAddItem;
property OnBeforeRemoveItem: TGMObjItemAddRemoveProc write SetOnBeforeRemoveItem;
// ---- ArrayListBase ---- //
function GetSorted: Boolean;
procedure SetSorted(const Value: Boolean);
procedure RemoveByIdx(const Index: LongInt; DelCount: LongInt = 1);
procedure Rotate(const Delta: LongInt; const StartPos: LongInt = 0);
procedure Exchange(const Index1, Index2: LongInt);
procedure Reverse;
procedure Sort;
function IndexOf(const AKey: IUnknown): LongInt;
function IndexOfNearest(const AKey: IUnknown): LongInt;
property Sorted: Boolean read GetSorted write SetSorted;
end;
TGMObjArrayList = class(TGMArrayListBase, IGMObjArrayList, IGMObjCollection)
protected
function ObjInsertIdx(const AObj: TObject): LongInt;
function InsertAt(const AObj: TObject; const Index: LongInt; const AReplaceIfExists: Boolean = False): Boolean; virtual;
function GetItem(const Index: LongInt): TObject; virtual;
function EntryAsIntf(const Index: LongInt): IUnknown; override;
procedure SetItem(const Index: LongInt; const Value: TObject); virtual;
procedure FreePointer(var Item: Pointer); override;
procedure SetOnAfterAddItem(const Value: TGMObjItemAddRemoveProc);
procedure SetOnBeforeRemoveItem(const Value: TGMObjItemAddRemoveProc);
procedure NotifyAfterAddItem(const AItem: Pointer; const AIndex: LongInt); override;
procedure NotifyBeforeRemoveItem(const AItem: Pointer; const AIndex: LongInt); override;
public
OnAfterAddItem: TGMObjItemAddRemoveProc;
OnBeforeRemoveItem: TGMObjItemAddRemoveProc;
constructor Create(const AFreeEntries: Boolean = False;
const AAcceptDuplicates: Boolean = True;
const ASorted: Boolean = False;
const ACompareFunc: TGMIntfCompareFunc = nil;
const ARefLifeTime: Boolean = False);
function CreateIterator(const AReverse: Boolean = False; const AConcurrentThreadLock: Boolean = False): IGMIterator; override;
function Add(const AObj: TObject; const AReplaceIfExists: Boolean = False): TObject; virtual;
function AddIdx(const AObj: TObject; const AReplaceIfExists: Boolean = False): LongInt; virtual;
function Insert(const AObj: TObject; const Index: LongInt; const AReplaceIfExists: Boolean = False): TObject; virtual;
function First: TObject; virtual;
function Last: TObject; virtual;
function IndexOfObj(const AObj: TObject): LongInt;
function RemoveByInstance(const AObj: TObject): Boolean;
//function FindObj(const AObj: TObject; var Index: LongInt): Boolean; virtual;
property Entries[const Idx: LongInt]: TObject read GetItem write SetItem; default; // <- Indexing is zero based!
property FreeEntries: Boolean read FFreeEntries write FFreeEntries;
end;
TGMObjectListIterator = class(TGMArrayListBaseIterator)
protected
procedure AssignOutEntry(out AEntry); override;
end;
TGMIntfItemAddRemoveProc = procedure(const Sender: TObject; const Item: IUnknown; const AIndex: LongInt) of object;
IGMIntfArrayList = interface(IGMIntfCollection) // IGMArrayListBase
['{E83BD4DC-E50E-4fc3-9161-9F5829BC6C92}']
function GetItem(const Index: LongInt): IUnknown;
procedure SetOnAfterAddItem(const Value: TGMIntfItemAddRemoveProc);
procedure SetOnBeforeRemoveItem(const Value: TGMIntfItemAddRemoveProc);
//function Add(const AIntf: IUnknown): IUnknown;
function AddIdx(const AIntf: IUnknown; const AReplaceIfExists: Boolean = False): LongInt;
function Insert(const AIntf: IUnknown; const Index: LongInt; const AReplaceIfExists: Boolean = False): IUnknown;
//function Remove(const AIntf: IUnknown): LongInt;
//function First: IUnknown;
//function Last: IUnknown;
function IndexOfObj(const AIntf: IUnknown): LongInt;
//function FindObj(const AIntf: IUnknown; var Index: LongInt): Boolean;
property Items[const Idx: LongInt]: IUnknown read GetItem; default;
property OnAfterAddItem: TGMIntfItemAddRemoveProc write SetOnAfterAddItem;
property OnBeforeRemoveItem: TGMIntfItemAddRemoveProc write SetOnBeforeRemoveItem;
// ---- ArrayListBase ---- //
function GetSorted: Boolean;
procedure SetSorted(const Value: Boolean);
procedure RemoveByIdx(const Index: LongInt; DelCount: LongInt = 1);
procedure Rotate(const Delta: LongInt; const StartPos: LongInt = 0);
procedure Exchange(const Index1, Index2: LongInt);
procedure Reverse;
procedure Sort;
function IndexOf(const AKey: IUnknown): LongInt;
function IndexOfNearest(const AKey: IUnknown): LongInt;
property Sorted: Boolean read GetSorted write SetSorted;
end;
TGMIntfArrayList = class(TGMArrayListBase, IGMIntfCollection, IGMIntfArrayList)
protected
function InsertAt(const AIntf: IUnknown; const Index: LongInt; const AReplaceIfExists: Boolean = False): Boolean; virtual;
function GetItem(const Index: LongInt): IUnknown; virtual;
function EntryAsIntf(const Index: LongInt): IUnknown; override;
procedure FreePointer(var Item: Pointer); override;
procedure SetOnAfterAddItem(const Value: TGMIntfItemAddRemoveProc);
procedure SetOnBeforeRemoveItem(const Value: TGMIntfItemAddRemoveProc);
procedure NotifyAfterAddItem(const AItem: Pointer; const AIndex: LongInt); override;
procedure NotifyBeforeRemoveItem(const AItem: Pointer; const AIndex: LongInt); override;
public
OnAfterAddItem: TGMIntfItemAddRemoveProc;
OnBeforeRemoveItem: TGMIntfItemAddRemoveProc;
Constructor Create(const AAcceptDuplicates: Boolean = True;
const ASorted: Boolean = False;
const ACompareFunc: TGMIntfCompareFunc = nil;
const ARefLifeTime: Boolean = True);
function CreateIterator(const AReverse: Boolean = False; const AConcurrentThreadLock: Boolean = False): IGMIterator; override;
function Add(const AIntf: IUnknown; const AReplaceIfExists: Boolean = False): IUnknown; virtual;
function AddIdx(const AIntf: IUnknown; const AReplaceIfExists: Boolean = False): LongInt; virtual;
function Insert(const AIntf: IUnknown; const Index: LongInt; const AReplaceIfExists: Boolean = False): IUnknown; virtual;
function Find(const AKey: IUnknown; out AEntry): Boolean; override;
function FindNearest(const AKey: IUnknown; out AEntry): Boolean; override;
function First: IUnknown; virtual;
function Last: IUnknown; virtual;
function IndexOfObj(const AIntf: IUnknown): LongInt;
function RemoveByInstance(const AIntf: IUnknown): Boolean;
//function FindObj(const Intf: IUnknown; var Index: LongInt): Boolean; virtual;
property Entries[const Idx: LongInt]: IUnknown read GetItem; default; // <- Indexing is zero based!
end;
TGMIntfArrayListIterator = class(TGMArrayListBaseIterator)
protected
procedure AssignOutEntry(out AEntry); override;
end;
{ ------------------- }
{ ---- AVL Trees ---- }
{ ------------------- }
TGMAvlTreeNodeDirection = (tndLeft, tndRight);
TGMAvlTreeNodeBase = class
public
Parent: TGMAvlTreeNodeBase; // , Left, Right
Children: array [TGMAvlTreeNodeDirection] of TGMAvlTreeNodeBase;
Balance: LongInt;
procedure ResetMembers;
function TreeHeight: LongInt;
function CalcBalance: LongInt;
function GetDataAsIntf: IUnknown; virtual; abstract;
function IsDataInstance(const AInstance): Boolean; virtual; abstract;
function GetChild(const AIdx: TGMAvlTreeNodeDirection): TGMAvlTreeNodeBase;
procedure SetChild(const AIdx: TGMAvlTreeNodeDirection; const AValue: TGMAvlTreeNodeBase);
property Child [const Idx: TGMAvlTreeNodeDirection]: TGMAvlTreeNodeBase read GetChild write SetChild; default;
property Left: TGMAvlTreeNodeBase read Children[tndLeft] write Children[tndLeft];
property Right: TGMAvlTreeNodeBase read Children[tndRight] write Children[tndRight];
end;
TGMAvlTreeNodeClass = class of TGMAvlTreeNodeBase;
TGMAvlTreeBase = class(TGMCollectionBase)
protected
function TreeNodeCreateClass: TGMAvlTreeNodeClass; virtual; abstract;
function CreateTreeNode: TGMAvlTreeNodeBase; virtual;
procedure FreeNode(const ANode: TGMAvlTreeNodeBase); virtual;
function Rotate(const ANode: TGMAvlTreeNodeBase; const ADirection: TGMAvlTreeNodeDirection): TGMAvlTreeNodeBase;
function DoubleRotate(const ANode: TGMAvlTreeNodeBase; const ADirection: TGMAvlTreeNodeDirection): TGMAvlTreeNodeBase;
procedure BalanceAfterInsert(const ANode: TGMAvlTreeNodeBase);
procedure BalanceAfterDelete(const ANode: TGMAvlTreeNodeBase);
function FindInsertPos(const AKey: IUnknown): TGMAvlTreeNodeBase;
procedure SetCompareFunc(const AValue: TGMIntfCompareFunc); override;
function AddNode(const ANode: TGMAvlTreeNodeBase): Boolean;
function FindNode(const AKey: IUnknown): TGMAvlTreeNodeBase;
function FindNearestNode(const AKey: IUnknown): TGMAvlTreeNodeBase;
procedure DeleteNode(const ANode: TGMAvlTreeNodeBase);
function RemoveByInstance(const AInstance): Boolean;
function SuccessorNode(const ANode: TGMAvlTreeNodeBase): TGMAvlTreeNodeBase;
function PredecessorNode(const ANode: TGMAvlTreeNodeBase): TGMAvlTreeNodeBase;
function FirstNode: TGMAvlTreeNodeBase;
function LastNode: TGMAvlTreeNodeBase;
public
Root: TGMAvlTreeNodeBase;
function RemoveByKey(const AKey: IUnknown): Boolean; override;
procedure Clear(const ANotify: Boolean = True); override;
procedure CheckIntegrity;
end;
//EAvlTreeInconsistency = class(Exception);
TGMAvlTreeIteratorBase = class(TGMIteratorBase)
protected
FCurrentNode: TGMAvlTreeNodeBase;
procedure AssignOutEntry(out AEntry); virtual; abstract;
public
procedure Reset; override;
function NextEntry(out AEntry): Boolean; override;
end;
TGMAvlObjTreeNode = class(TGMAvlTreeNodeBase)
public
Data: TObject;
function GetDataAsIntf: IUnknown; override;
function IsDataInstance(const AInstance): Boolean; override;
end;
TGMAvlObjTree = class(TGMAvlTreeBase, IGMObjCollection)
protected
FFreeEntries: Boolean;
function TreeNodeCreateClass: TGMAvlTreeNodeClass; override;
procedure FreeNode(const ANode: TGMAvlTreeNodeBase); override;
public
constructor Create(const AFreeEntries: Boolean; const AAcceptDuplicates: Boolean = False; const ACompareFunc: TGMIntfCompareFunc = nil; const ARefLifeTime: Boolean = False); reintroduce; overload;
function CreateIterator(const AReverse: Boolean = False; const AConcurrentThreadLock: Boolean = False): IGMIterator; override;
function Add(const ANewEntry: TObject; const AReplaceIfExists: Boolean = False): TObject;
function Find(const AKey: IUnknown; out AEntry): Boolean; override;
function FindNearest(const AKey: IUnknown; out AEntry): Boolean; override;
function RemoveByInstance(const AObj: TObject): Boolean;
function First: TObject;
function Last: TObject;
end;
TGMAvlObjectTreeIterator = class(TGMAvlTreeIteratorBase)
protected
procedure AssignOutEntry(out AEntry); override;
end;
TGMAvlIntfTreeNode = class(TGMAvlTreeNodeBase)
public
Data: IUnknown;
function GetDataAsIntf: IUnknown; override;
function IsDataInstance(const AInstance): Boolean; override;
end;
TGMAvlIntfTree = class(TGMAvlTreeBase, IGMIntfCollection)
protected
function TreeNodeCreateClass: TGMAvlTreeNodeClass; override;
public
function CreateIterator(const AReverse: Boolean = False; const AConcurrentThreadLock: Boolean = False): IGMIterator; override;
function Add(const ANewEntry: IUnknown; const AReplaceIfExists: Boolean = False): IUnknown;
function Find(const AKey: IUnknown; out AEntry): Boolean; override;
function FindNearest(const AKey: IUnknown; out AEntry): Boolean; override;
function RemoveByInstance(const AIntf: IUnknown): Boolean;
function First: IUnknown;
function Last: IUnknown;
end;
TGMAvlIntfTreeIterator = class(TGMAvlTreeIteratorBase)
protected
procedure AssignOutEntry(out AEntry); override;
end;
{ --------------------- }
{ ---- Hash Tables ---- }
{ --------------------- }
//
// A multi-level extendable hashing algorithm is implmented here. Offering good performance along with
// low memory consumption. Even in case of skewed distributed hash codes. And it scales gracefully
// from only a few entries to millions of entries.
//
const
cMaxHashBucketSize = 8; // <- when using sizes greater than 256 extend type TBucketIdx accordingly!
cMaxHashCodeBits = SizeOf(TGMHashCode) * 8;
cMaxHashBitsPerDirLevel = 6; // <- when using more than 8 bits extend type TBucketDirIdx accordingly!
cMinHashBitsPerDirLevel = 4; // <- when using more than 8 bits extend type TBucketDirIdx accordingly!
type
TGMHashTableBase = class;
TGMHashEntryBucket = class;
IGMHashEntryBucket = interface(IUnknown)
['{E31D8735-3491-4D0C-B421-4FF1458E3ED9}']
function Obj: TGMHashEntryBucket;
end;
TBucketIdx = Word; // <- if all hash bits are used and still there are duplicates more than cMaxHashBucketSize entries may be put into a single bucket!
TGMHashEntryBucket = class(TGMRefLifeObject, IGMHashEntryBucket)
protected
FEntries: PPointerList;
FCount: TBucketIdx;
FCapacity: TBucketIdx;
FHashTable: TGMHashTableBase;
//FHashBitCount: Byte;
function InsertIdx(const AKey: IUnknown): TBucketIdx;
procedure SetCapacity(const NewCapacity: TBucketIdx);
function FindIdxOfKey(const AKey: IUnknown; var Idx: TBucketIdx): Boolean;
public
constructor Create(const AHashTable: TGMHashTableBase; const ARefLifeTime: Boolean = True); reintroduce; // const AHashBitCount: Byte;
destructor Destroy; override;
procedure Clear(const AFreeEntries: Boolean);
function Obj: TGMHashEntryBucket;
function FindKey(const AKey: IUnknown; out AEntry): Boolean;
function AddPointer(const ANewEntry: Pointer): Boolean;
procedure RemoveByIdx(const AIdx: LongInt);
function RemoveByKey(const AKey: IUnknown): Boolean;
function RemovePointer(const AInstance: Pointer): Boolean;
end;
TGMHashBitMaskDirectory = class;
IGMHashBitMaskDirectory = interface(IUnknown)
['{950EF49C-B643-455C-A1B5-AB3C03B8A1F6}']
function Obj: TGMHashBitMaskDirectory;
end;
TBucketDirIdx = Byte;
TGMHashBitMaskDirectory = class(TGMRefLifeObject, IGMHashBitMaskDirectory)
protected
FHashBitCount: Byte;
FHashBitOffs: Byte;
FMaxHashBits: Byte;
FHashBitMask: TGMHashCode;
FHashTable: TGMHashTableBase;
FDirEntries: array of IUnknown;
FAssignedCount: TBucketDirIdx;
procedure ExpandHash(const ADirEntryIdx: LongInt);
procedure ReHashBuketEntries(const ABucket: IGMHashEntryBucket);
public
constructor Create(const AHashTable: TGMHashTableBase; const AMaxHashBits: Byte; const AHashBitOffs: Byte = 0; const ARefLifeTime: Boolean = True); reintroduce;
function Obj: TGMHashBitMaskDirectory;
function CalcDirEntryIndex(const AHashCode: TGMHashCode): LongInt;
function FindDirEntry(const AHashCode: TGMHashCode): IUnknown;
function FindBucket(const AHashCode: TGMHashCode; var ABucket: IGMHashEntryBucket): Boolean;
function AddPointer(const AHashCode: TGMHashCode; const ANewEntry: Pointer): Boolean;
function RemoveByKey(const AHashCode: TGMHashCode; const AKey: IUnknown): Boolean;
function RemovePointer(const AInstance: Pointer): Boolean;
function FirstEntry: Pointer;
function LastEntry: Pointer;
end;
TGMHashTableBase = class (TGMCollectionBase)
protected
FFreeEntries: Boolean;
FRootDirectory: IGMHashBitMaskDirectory;
function BuildHashCode(const AKey: IUnknown): TGMHashCode; virtual;
function AddPointer(const AHashCode: TGMHashCode; ANewEntry: Pointer): Boolean;
function EntryAsIntf(const AEntryPtr: Pointer): IUnknown; virtual; abstract;
procedure FreePointer(var AEntryPtr: Pointer); virtual; abstract;
procedure AssignOutEntry(const AEntryPtr: Pointer; out AEntry); virtual; abstract;
function FirstEntry: Pointer;
function LastEntry: Pointer;
procedure DoAfterRemove;
function RemovePointer(const AInstance: Pointer): Boolean;
//procedure SetCompareFunc(const AValue: TGMIntfCompareFunc); override;
public
function CreateIterator(const AReverse: Boolean = False; const AConcurrentThreadLock: Boolean = False): IGMIterator; override;
function Find(const AKey: IUnknown; out AEntry): Boolean; override;
function FindNearest(const AKey: IUnknown; out AEntry): Boolean; override;
function RemoveByKey(const AKey: IUnknown): Boolean; override;
procedure Clear(const ANotify: Boolean = True); override;
end;
PHashIteratorStackRec = ^THashIteratorStackRec;
THashIteratorStackRec = record
Directory: IGMHashBitMaskDirectory;
DirEntryIdx: LongInt; // <- LongInt NOT TBucketDirIdx to support negative values!
end;
TGMHashTableIterator = class(TGMIteratorBase)
protected
FDirStack: array of THashIteratorStackRec;
FCurrentBucket: IGMHashEntryBucket;
FCurrentBucketEntryIdx: LongInt; // <- LongInt NOT TBucketIdx to support negative values!
public
procedure Reset; override;
function NextEntry(out AEntry): Boolean; override;
end;
TGMObjHashTable = class(TGMHashTableBase, IGMObjCollection)
protected
function EntryAsIntf(const AEntryPtr: Pointer): IUnknown; override;
procedure FreePointer(var AEntryPtr: Pointer); override;
procedure AssignOutEntry(const AEntryPtr: Pointer; out AEntry); override;
public
constructor Create(const AFreeEntries: Boolean = False;
const AAcceptDuplicates: Boolean = True;
const ACompareFunc: TGMIntfCompareFunc = nil;
const ARefLifeTime: Boolean = False); reintroduce; overload;
function Add(const ANewEntry: TObject; const AReplaceIfExists: Boolean = False): TObject;
function RemoveByInstance(const AObj: TObject): Boolean;
function First: TObject;
function Last: TObject;
end;
TGMIntfHashTable = class(TGMHashTableBase, IGMIntfCollection)
protected
function EntryAsIntf(const AEntryPtr: Pointer): IUnknown; override;
procedure FreePointer(var AEntryPtr: Pointer); override;
procedure AssignOutEntry(const AEntryPtr: Pointer; out AEntry); override;
public
constructor Create(const AAcceptDuplicates: Boolean = True;
const ACompareFunc: TGMIntfCompareFunc = nil;
const ARefLifeTime: Boolean = False); override;
function Add(const ANewEntry: IUnknown; const AReplaceIfExists: Boolean = False): IUnknown;
function RemoveByInstance(const AIntf: IUnknown): Boolean;
function First: IUnknown;
function Last: IUnknown;
end;
function GMHashCodeFromString(const AValue: String): TGMHashCode;
{ --------------------- }
{ ---- Integer Map ---- }
{ --------------------- }
type
TGMIntegerMap = class;
IGMIntegerMap = interface(IUnknown)
['{59388B7E-4264-4128-992D-CCE1BD926721}']
function Obj: TGMIntegerMap;
end;
PLongIntArray = ^TLongIntArray;
TLongIntArray = array [0 .. cMaxIntArraySize-1] of LongInt;
TNotifyIntMapChangeProc = procedure (const Value: LongInt) of Object;
TIndexDecideFunc = function (const Value: LongInt): Boolean of Object;
TGMIntegerMap = class(TGMRefLifeObject, IGMIntegerMap, IGMMapIntegerOnInteger, IGMGetCount, IGMExecuteOperation)
protected
FValues: PLongIntArray;
FCount: LongInt;
FCapacity: LongInt;
FNotifyProc: TNotifyIntMapChangeProc;
procedure SetCapacity(const NewCapacity: LongInt);
function GetMappedValue(Index: LongInt): LongInt;
function InsertIdx(const Value: LongInt): LongInt;
function GetCount: LongInt; stdcall;
function MapIntegerOnInteger(const MapValue: LongInt): LongInt; virtual; stdcall;
function ExecuteOperation(const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; virtual; stdcall;
procedure IntMapChanged(const Value: LongInt);
public // const AControl: TObject;
OnDecideAddValue: TIndexDecideFunc;
constructor Create(const ANotifyProc: TNotifyIntMapChangeProc; const ARefLifeTime: Boolean = False); reintroduce; overload; virtual;
destructor Destroy; override;
function Obj: TGMIntegerMap;
procedure Add(const Value: LongInt); virtual;
procedure Remove(const Value: LongInt); virtual;
procedure Toggle(const Value: LongInt); virtual;
procedure Clear(const Notify: Boolean = True); virtual;
procedure AddRange(Value1, Value2: LongInt); virtual;
function Contains(const Value: LongInt): Boolean; virtual;
function IsEmpty: Boolean;
//property Control: TObject read FControl;
property Values[Index: LongInt]: LongInt read GetMappedValue; default;
property Count: LongInt read FCount;
end;
//
// Collection Helpers
//
function GMCollectionContains(const ACollection, AKey: IUnknown): Boolean;
function GMCollectionAddAll(const ASrcCollection, ADstCollection: IUnknown): LongInt;
//
// Helpers when not using GMCommon and GMIntf units
//
{$IFDEF STANDALONE_COLLECTIONS}
function GMStringJoin(const Value, Separator, Append: String): String;
function GMHResultFromWin32(const WinErrorCode: LongWord): HRESULT;
function GMQueryInterface(const Obj: IUnknown; const IID: TGUID; out Intf): Boolean;
function GMIsInRange(const Value, Min, Max: LongInt): Boolean;
function GMBoundedInt(Value, Min, Max: LongInt; const MinBased: Boolean = True): LongInt;
procedure GMCheckQueryInterface(const Obj: IUnknown; const IID: TGUID; out Intf; const CallingName: String);
function GMHrSucceeded(const AErrorCode: HResult): Boolean;
function GMSysErrorMsg(const ErrorCode: LongInt; const Params: array of PChar): string;
function GMObjAsIntf(const Obj: TObject): IUnknown;
procedure GMCheckIntRange(const ValueName: String; const Value, MinValue, MaxValue: LongInt; const Obj: TObject; const CallingName: String);
function Min(A, B: LongInt): LongInt;
function Max(A, B: LongInt): LongInt;
{$ENDIF}
implementation
uses SysUtils {$IFNDEF STANDALONE_COLLECTIONS}, GMCommon{$ENDIF};
//const
//
// CStrErrNameSep = ' - ';
resourcestring
RStrListNotSorted = 'Operation not supported on unsorted Lists';
RStrListSorted = 'Operation not supported on sorted Lists';
RStrListIndex = 'List Index';
RStrListCapacityError = 'List capacity (%d) must be smaller than (%d)';
RStrInvalidCompareResult = 'Invalid Compare Result';
RStrInvalidRotateDelta = 'Invalid Rotate Delta: %d';
RStrInvalidRotateStartPos = 'Invalid Rotate start Position: %d';
RStrMapIndex = 'Map Index';
RStrAvlTreeIntegrityViolation = 'AVL-Tree integrity violation';
RStrLeftChildsParentNotUs = 'The parent member of the left child does not point back to us';
RStrLeftChildGreaterThanUs = 'The left childs value is greater than ours, but it should be less or equal';
RStrRightChildsParentNotUs = 'The parent member of the right child does not point back to us';
RStrWeGreaterThanRightChild = 'Our value is greater than that of our right child, but it should be less or equal.';
RStrWrongNodeBalanceFmt = 'Wrong node balance %d it should be %d';
RStrWrongNodeCountFmt = 'Wrong total tree node count %d it should be %d';
RStrNodeParentLinkError = 'AVL-Tree: The parent node is not correctly linked to the child node';
RStrNoNearestInHashFmt = 'FindNearest not supported in class %s because hashing is not order preserving';
{$IFDEF DEBUG}
RStrDuplicateHashEntry = 'Duplicate hash entry';
{$ENDIF}
{$IFDEF STANDALONE_COLLECTIONS}
RStrTheObjIsNil = 'The Object is nil';
RStrMsgOutOfRangeFmt = '%s out of range: %d. The Value must be in Interval [%d, %d]';
{$ENDIF}
{$IFDEF STANDALONE_COLLECTIONS}
const
cGrowDeltaDiv = 5; // <- 20%
cGrowDeltaMax = 1024;
{$ENDIF}
{ ------------------------------------------------------------------ }
{ ---- Routines needed when not using GMIntf and GMCommon units ---- }
{ ------------------------------------------------------------------ }
{$IFDEF STANDALONE_COLLECTIONS}
function GMStringJoin(const Value, Separator, Append: String): String;
begin
if Append = '' then Result := Value else
if Value = '' then Result := Append else Result := Value + Separator + Append;
end;
function GMHResultFromWin32(const WinErrorCode: LongWord): HRESULT;
//
// Looks like Borland Windows.HResultFromWin32 is not correct ..
//
// #define FACILITY_WIN32 7
// #define HRESULT_FROM_WIN32(x) ((HRESULT)(x) <= 0 ? ((HRESULT)(x)) \
// : ((HRESULT) (((x) & 0x0000FFFF) | (FACILITY_WIN32 << 16) | 0x80000000)))
begin
Result := HResult(WinErrorCode);
if Result > 0 then Result := ((Result and $0000FFFF) or (FACILITY_WIN32 shl 16) or HRESULT($80000000));
end;
function GMSysErrorMsg(const ErrorCode: LongInt; const Params: array of PChar): string;
var ApiCode: DWORD; PParams: Pointer;
function BuildSysErrMsg(Flags: DWORD): String;
var Buffer: PChar; Len: DWORD;
begin
Len := FormatMessage(Flags or FORMAT_MESSAGE_ALLOCATE_BUFFER, nil, DWORD(ErrorCode), 0, PChar(@Buffer), 0, PParams);
if Len = 0 then begin ApiCode := GetLastError; Result := ''; end else
begin
ApiCode := ERROR_SUCCESS;
while (Len > 0) and (Buffer[Len - 1] in [#0..#32, '.']) do Dec(Len);
SetString(Result, Buffer, Len);
//if LocalFree(HLOCAL(Buffer)) <> 0 then GMTrace('GMSysErrorMsg - LocalFree failed!', tpWarning);
end;
end;
begin
if Length(Params) = 0 then PParams := nil else PParams := @Params[Low(Params)];
Result := BuildSysErrMsg(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_ARGUMENT_ARRAY);
if (Result = '') and (ApiCode = ERROR_INVALID_PARAMETER) then
Result := BuildSysErrMsg(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_ARGUMENT_ARRAY or FORMAT_MESSAGE_IGNORE_INSERTS);
end;
function GMQueryInterface(const Obj: IUnknown; const IID: TGUID; out Intf): Boolean;
begin
Result := (Obj <> nil) and (Obj.QueryInterface(IID, Intf) = S_OK);
end;
function GMHrSucceeded(const AErrorCode: HResult): Boolean;
begin
Result := AErrorCode and $80000000 = 0;
end;
function GMIntfName(const AIntf: IUnknown): String;
begin
Result := '';
end;
function GMObjName(const AObj: TObject): String;
begin
if AObj <> nil then Result := AObj.ClassName else Result := '';
end;
procedure GMCheckQueryInterface(const Obj: IUnknown; const IID: TGUID; out Intf; const CallingName: String);
const cStrRoutineName = 'GMCheckQueryInterface';
var CallerName: String; Hr: HResult;
//function LocalBuildCallingName: String;
//begin
// if CallerName = '' then CallerName := GMStringJoin(BuildCallingName(CallingName, cStrRoutineName), ' - ',
// Format('QueryInterface<%s>("%s")', [GMIntfClassName(Obj), GMGuidToString(IID)]));
// Result := CallerName;
//end;
begin
//GMCheckPointerAssigned(Pointer(Obj), RStrTheObject, nil, CallerName);
if Obj = nil then raise Exception.Create(GMStringJoin(GMStringJoin(GMIntfName(Obj), cStrErrNameSep, CallingName), ': ', RStrTheObjIsNil));
Hr := Obj.QueryInterface(IID, Intf);
if not GMHrSucceeded(Hr) then raise Exception.Create(GMStringJoin(GMStringJoin(GMIntfName(Obj), cStrErrNameSep, CallingName), ': ', GMSysErrorMsg(Hr, [])));
//if Obj.QueryInterface(IID, Intf) <> S_OK then raise EGMException.IntfError(MsgIntfNotSupported(RStrTheObject, IID), Obj, BuildCallingName(CallingName, cStrRoutineName));
end;
function GMObjAsIntf(const Obj: TObject): IUnknown;
begin
if (Obj = nil) or not Obj.GetInterface(IUnknown, Result) then Result := nil;
end;
function GMBoundedInt(Value, Min, Max: LongInt; const MinBased: Boolean = True): LongInt;
begin
if Min > Max then if MinBased then Max := Min else Min := Max;
if Value < Min then Result := Min
else
if Value > Max then Result := Max
else
Result := Value;
end;
function GMCompareByObject(const ItemA, ItemB: IUnknown): TGMCompareResult;
begin
if PtrUInt(ItemA) > PtrUInt(ItemB) then Result := crAGreaterThanB else
if PtrUInt(ItemA) = PtrUInt(ItemB) then Result := crAEqualToB else
Result := crALessThanB;
end;
function GMIsInRange(const Value, Min, Max: LongInt): Boolean;
begin
Result := (Value >= Min) and (Value <= Max);
end;
procedure GMCheckIntRange(const ValueName: String; const Value, MinValue, MaxValue: LongInt; const Obj: TObject; const CallingName: String);
const cStrRoutineName = 'GMCheckIntRange';
begin
if not GMIsInRange(Value, MinValue, MaxValue) then
raise Exception.Create(GMStringJoin(GMStringJoin(GMObjName(Obj), cStrErrNameSep, CallingName), ': ', Format(RStrMsgOutOfRangeFmt, [ValueName, Value, MinValue, MaxValue])));
end;
function Min(A, B: LongInt): LongInt;
begin
if A < B then Result := A else Result := B;
end;
function Max(A, B: LongInt): LongInt;
begin
if A > B then Result := A else Result := B;
end;
{$ENDIF}
{ ------------------------- }
{ ---- Global Routines ---- }
{ ------------------------- }
function GrowDelta(const ACurrentCapacity: LongInt): LongInt;
begin
Result := GMBoundedInt(ACurrentCapacity div cGrowDeltaDiv, 1, cGrowDeltaMax);
end;
function GMHashCodeFromString(const AValue: String): TGMHashCode;
var i: LongInt;
begin
Result := 0;
for i:=1 to Length(AValue) do Result := Result + (Ord(AValue[i]) * (i - 1) * 256);
end;
function GMCollectionContains(const ACollection, AKey: IUnknown): Boolean;
var PICollection: IGMCollection; Entry: IUnknown;
begin
if not GMQUeryInterface(ACollection, IGMCollection, PICollection) then Result := False else
Result := PICollection.Find(AKey, Entry);
end;
function GMCollectionAddAll(const ASrcCollection, ADstCollection: IUnknown): LongInt;
var IntfSrc, IntfDst: IGMIntfCollection; it: IGMIterator; UnkEntry: IUnknown;
ObjSrc, ObjDst: IGMObjCollection; ObjEntry: TObject;
begin
Result := 0;
if GMQueryInterface(ASrcCollection, IGMIntfCollection, IntfSrc) and
GMQueryInterface(ADstCollection, IGMIntfCollection, IntfDst) then
begin
it := IntfSrc.CreateIterator;
while it.NextEntry(UnkEntry) do begin IntfDst.Add(UnkEntry); Inc(Result); end;
end else
if GMQueryInterface(ASrcCollection, IGMObjCollection, ObjSrc) and
GMQueryInterface(ADstCollection, IGMObjCollection, ObjDst) then
begin
it := ObjSrc.CreateIterator;
while it.NextEntry(ObjEntry) do begin ObjDst.Add(ObjEntry); Inc(Result); end;
end;
end;
procedure RaiseError(const AMsg: String; const ACaller: TObject = nil; const ACallingName: String = '');
begin
{$IFNDEF STANDALONE_COLLECTIONS}
raise EGMException.ObjError(AMsg, ACaller, ACallingName);
{$ELSE}
raise Exception.Create(GMStringJoin(GMStringJoin(GMObjName(ACaller), cStrErrNameSep, ACallingName), ': ', AMsg));
{$ENDIF}
end;
{ -------------------------- }
{ ---- TGMRefLifeObject ---- }
{ -------------------------- }
{$IFDEF STANDALONE_COLLECTIONS}
constructor TGMRefLifeObject.Create(const ARefLifeTime: Boolean);
begin
inherited Create;
FRefLifeTime := ARefLifeTime;
FRefCount := 1; // <- artificial RefCount during construction, avoiding immediate destruction
// when local interface variables to this instance are used by other objects during construction.
end;
procedure TGMRefLifeObject.AfterConstruction;
begin
Dec(FRefCount);
inherited AfterConstruction;
end;
procedure TGMRefLifeObject.BeforeDestruction;
begin
inherited BeforeDestruction;
Inc(FRefCount);
end;
//destructor TGMRefLifeObject.Destroy;
//begin
//inherited Destroy;
//if Assigned(vfGMCheckRefCountOnDestroy) then vfGMCheckRefCountOnDestroy(RefCount-1, Self);
//end;
procedure TGMRefLifeObject.OnFinalRelease;
begin
Free;
end;
//function TGMRefLifeObject.CreateCopyQI(const IID: TGUID; out Intf): HResult;
//var PIUnknown: IUnknown; PIAssign: IGMAssignFromObj;
//begin
//PIUnknown := TGMRefLifeObjClass(ClassType).Create(True);
//Result := PIUnknown.QueryInterface(IID, Intf);
//if (Result = S_OK) and (PIUnknown.QueryInterface(IGMAssignFromObj, PIAssign) = S_OK) then PIAssign.AssignFromObj(Self);
//end;
//function TGMRefLifeObject.GetClassName: PChar;
//var RetVal: String;
//begin
//RetVal := ClassName;
//Result := PChar(RetVal);
//end;
//
//function TGMRefLifeObject.GetClassType: TClass;
//begin
//Result := ClassType;
//end;
//
//function TGMRefLifeObject.GetInstance: TObject;
//begin
//Result := Self;
//end;
//
//function TGMRefLifeObject.GetTypeInfo: PTypeInfo;
//begin
//Result := ClassInfo;
//end;
function TGMRefLifeObject.QueryInterface({$IFDEF FPC}constref{$ELSE}const{$ENDIF} IID: TGUID; out Intf): HResult;
begin
if GetInterface(IID, Intf) then Result := S_OK else Result := E_NOINTERFACE;
//GMTraceQueryInterface(Self, IID, Result);
end;
function TGMRefLifeObject._AddRef: LongInt;
begin
Result := InterlockedIncrement(FRefCount);
end;
function TGMRefLifeObject._Release: LongInt;
begin
Result := InterlockedDecrement(FRefCount);
if (Result = 0) and RefLifeTime then OnFinalRelease;
end;
{$ENDIF}
{ ---------------------------- }
{ ---- TGMCriticalSection ---- }
{ ---------------------------- }
{$IFDEF STANDALONE_COLLECTIONS}
constructor TGMCriticalSection.Create(const ARefLifeTime: Boolean);
begin
inherited Create(ARefLifeTime);
Windows.InitializeCriticalSection(FCriticalSection);
end;
destructor TGMCriticalSection.Destroy;
begin
Windows.DeleteCriticalSection(FCriticalSection);
inherited Destroy;
end;
procedure TGMCriticalSection.EnterCriticalSection;
begin
Windows.EnterCriticalSection(FCriticalSection);
end;
procedure TGMCriticalSection.LeaveCriticalSection;
begin
Windows.LeaveCriticalSection(FCriticalSection);
end;
function TGMCriticalSection.TryEnterCriticalSection: Boolean;
begin
Result := Windows.TryEnterCriticalSection(FCriticalSection);
end;
{$ENDIF}
{ -------------------------------- }
{ ---- TGMCriticalSectionLock ---- }
{ -------------------------------- }
{$IFDEF STANDALONE_COLLECTIONS}
constructor TGMCriticalSectionLock.Create(const ACriticalSection: IUnknown; const ARefLifeTime: Boolean);
const cStrMethodName = 'TGMCriticalSectionLock.Create';
begin
inherited Create(ARefLifeTime);
if ACriticalSection = nil then Exit; // <- allow nil!
// force ACriticalSection to support IGMCriticalSection interface
GMCheckQueryInterface(ACriticalSection, IGMCriticalSection, FCriticalSection, cStrMethodName);
if FCriticalSection <> nil then FCriticalSection.EnterCriticalSection;
end;
destructor TGMCriticalSectionLock.Destroy;
begin
if FCriticalSection <> nil then FCriticalSection.LeaveCriticalSection;
inherited Destroy;
end;
{$ENDIF}
{ --------------------------- }
{ ---- TGMCollectionBase ---- }
{ --------------------------- }
constructor TGMCollectionBase.Create(const AAcceptDuplicates: Boolean; const ACompareFunc: TGMIntfCompareFunc; const ARefLifeTime: Boolean);
begin
inherited Create(ARefLifeTime);
FCriticalSection := TGMCriticalSection.Create(True);
FAcceptDuplicates := AAcceptDuplicates;
FCompareFunc := ACompareFunc;
end;
destructor TGMCollectionBase.Destroy;
begin
Clear(False);
inherited Destroy;
end;
function TGMCollectionBase.GetCount: LongInt;
begin
CriticalSection.EnterCriticalSection; // <- not technically needed, but let modifications finish before somebody else may read the count
try
Result := FCount;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
procedure TGMCollectionBase.NotifyAfterCountChanged(const OldCount, NewCount: LongInt);
begin
if Assigned(FOnAfterCountChanged) then FOnAfterCountChanged(Self, OldCount, NewCount);
end;
function TGMCollectionBase.CompareEntries(const EntryA, EntryB: IUnknown): TGMCompareResult;
begin
if Assigned(FCompareFunc) then
Result := FCompareFunc(EntryA, EntryB)
else
Result := GMCompareByObject(EntryA, EntryB);
end;
procedure TGMCollectionBase.SetOnAfterCountChanged(const Value: TGMCountChangedProc);
begin
FOnAfterCountChanged := Value;
end;
procedure TGMCollectionBase.SetCompareFunc(const AValue: TGMIntfCompareFunc);
begin
CriticalSection.EnterCriticalSection;
try
if Addr(AValue) <> Addr(CompareItemFunc) then
begin
FCompareFunc := AValue;
AfterCompareFuncChanged;
end;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
procedure TGMCollectionBase.AfterCompareFuncChanged;
begin
// Nothing!
end;
function TGMCollectionBase.IsEmpty: Boolean;
begin
CriticalSection.EnterCriticalSection; // <- not technically needed, but let modifications finish before somebody else may read the count
try
Result := FCount = 0;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMCollectionBase.IsValidIndex(const AIndex: Integer): Boolean;
begin
Result := GMIsInRange(AIndex, 0, FCount-1);
end;
{ ------------------------- }
{ ---- TGMIteratorBase ---- }
{ ------------------------- }
constructor TGMIteratorBase.Create(const ACollection: TObject; const AReverse, AConcurrentThreadLock: Boolean; const ARefLifeTime: Boolean);
begin
inherited Create(ARefLifeTime);
FCollection := ACollection;
FReverse := AReverse;
if AConcurrentThreadLock then FSyncLock := TGMCriticalSectionLock.Create(GMObjAsIntf(ACollection));
Reset;
end;
{ -------------------------- }
{ ---- TGMArrayListBase ---- }
{ -------------------------- }
Constructor TGMArrayListBase.Create(const AAcceptDuplicates: Boolean = True;
const ASorted: Boolean = False;
const ACompareFunc: TGMIntfCompareFunc = nil;
const ARefLifeTime: Boolean = False);
begin
inherited Create(AAcceptDuplicates, ACompareFunc, ARefLifeTime);
FSorted := ASorted;
end;
function TGMArrayListBase.GetSorted: Boolean;
begin
Result := FSorted;
end;
procedure TGMArrayListBase.CheckSorted;
const cStrMethodName = 'CheckSorted';
begin
if not FSorted then RaiseError(RStrListNotSorted, Self, cStrMethodName);
end;
procedure TGMArrayListBase.CheckUnsorted;
const cStrMethodName = 'CheckUnsorted';
begin
if FSorted then RaiseError(RStrListSorted, Self, cStrMethodName);
end;
function TGMArrayListBase.ExecuteOperation(const Operation: LongInt; const Parameter: IUnknown = nil): Boolean;
begin
Result := True;
case Operation of
{$IFNDEF STANDALONE_COLLECTIONS}
Ord(opClear): Clear;
{$ELSE}
0: Clear;
{$ENDIF}
else Result := False;
end;
end;
function TGMArrayListBase.GetIntfByPosition(const Position: LongInt; const IID: TGUID; out Intf): HResult;
//const cStrMethodName = 'GetIntfByPosition';
var PIUnkItem: IUnknown; // SyncLock
begin
// SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
Result := GMHResultFromWin32(ERROR_INVALID_INDEX);
if not GMIsInRange(Position, 0, FCount-1) then Exit;
//GMCheckIntRange(RStrListIndex, Position, 0, FCount-1, Self, cStrMethodName);
PIUnkItem := EntryAsIntf(Position);
if PIUnkItem <> nil then Result := PIUnkItem.QueryInterface(IID, Intf);
finally
CriticalSection.LeaveCriticalSection;
end;
end;
procedure TGMArrayListBase.SetCapacity(const NewCapacity: LongInt);
//var SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
{TODO: Bessere Fehlermeldung}
if (NewCapacity < 0) or (NewCapacity > cMaxPtrArraySize) then RaiseError(Format(RStrListCapacityError, [NewCapacity, cMaxPtrArraySize]), Self, 'SetCapacity');
if NewCapacity <> FCapacity then
begin
ReallocMem(FEntries, NewCapacity * SizeOf(Pointer));
FCapacity := NewCapacity;
end;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
procedure TGMArrayListBase.Clear(const ANotify: Boolean);
var i, OldCount: LongInt; //SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
// Better free in reverse order
if ANotify or FFreeEntries then
for i:=FCount-1 downto 0 do
begin
if ANotify then NotifyBeforeRemoveItem(TObject(FEntries^[i]), i);
if FFreeEntries then FreePointer(FEntries^[i]);
end;
OldCount := FCount;
SetCapacity(0);
FCount := 0;
if ANotify then NotifyAfterCountChanged(OldCount, 0);
finally
CriticalSection.LeaveCriticalSection;
end;
end;
procedure TGMArrayListBase.SetSorted(const Value: Boolean);
//var SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
if Value <> FSorted then
begin
FSorted := Value;
if Value then Sort;
end;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
procedure TGMArrayListBase.AfterCompareFuncChanged;
begin
if Assigned(FCompareFunc) and Sorted then Sort;
end;
function TGMArrayListBase.IndexOfPointer(const Ptr: Pointer): LongInt;
begin
for Result := 0 to FCount-1 do if FEntries^[Result] = Ptr then Exit;
Result := cInvalidItemIdx;
end;
function TGMArrayListBase.IsDuplicate(const AKey: IUnknown; const Index: LongInt): Boolean;
var i: LongInt;
begin
Result := False;
if not FAcceptDuplicates then
begin
if Sorted then
Result := IsValidIndex(Index) and (CompareEntries(EntryAsIntf(Index), AKey) = crAEqualToB)
else
for i:=0 to FCount-1 do if CompareEntries(EntryAsIntf(i), AKey) = crAEqualToB then begin Result := True; Break; end;
end;
end;
procedure TGMArrayListBase.InsertPointer(const AInstance: Pointer; const Index: LongInt);
const cStrMethodName = 'InsertPointer';
begin
GMCheckIntRange(RStrListIndex, Index, 0, FCount, Self, cStrMethodName);
if FCount = FCapacity then SetCapacity(FCapacity + GrowDelta(FCapacity));
if Index < FCount then System.Move(FEntries^[Index], FEntries^[Index + 1], (FCount - Index) * SizeOf(Pointer));
FEntries^[Index] := AInstance;
Inc(FCount);
NotifyAfterAddItem(AInstance, Index);
NotifyAfterCountChanged(FCount-1, FCount);
end;
{procedure TGMArrayListBase.Pack;
var i: LongInt; //SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
for i := FCount - 1 downto 0 do if FEntries^[i] = nil then Delete(i);
finally
CriticalSection.LeaveCriticalSection;
end;
end;}
{$IFNDEF STANDALONE_COLLECTIONS}
procedure TGMArrayListBase.LoadData(const Source: IGMValueStorage);
{$ELSE}
procedure TGMArrayListBase.LoadData(const Source: IUnknown);
{$ENDIF}
var i: LongInt; PILoadStore: IGMLoadStoreData;
begin
for i:=0 to Count-1 do if (GetIntfByPosition(i, IGMLoadStoreData, PILoadStore) = S_OK) then PILoadStore.LoadData(Source);
end;
{$IFNDEF STANDALONE_COLLECTIONS}
procedure TGMArrayListBase.StoreData(const Dest: IGMValueStorage);
{$ELSE}
procedure TGMArrayListBase.StoreData(const Dest: IUnknown);
{$ENDIF}
var i: LongInt; PILoadStore: IGMLoadStoreData;
begin
for i:=0 to Count-1 do if (GetIntfByPosition(i, IGMLoadStoreData, PILoadStore) = S_OK) then PILoadStore.StoreData(Dest);
end;
procedure TGMArrayListBase.RemoveByIdx(const Index: LongInt; DelCount: LongInt);
const cStrMethodName = 'Delete';
//var SyncLock: IUnknown;
var i: LongInt;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
GMCheckIntRange(RStrListIndex, Index, 0, FCount-1, Self, cStrMethodName);
Delcount := Min(DelCount, FCount - Index);
if DelCount <= 0 then Exit; // <- GMCheckIntRange should never raise with this
for i:=Index to Index + Delcount-1 do
begin
NotifyBeforeRemoveItem(FEntries^[i], i);
if FFreeEntries then {if FEntries^[i] <> nil then} FreePointer(FEntries^[i]);
end;
Dec(FCount, Delcount);
if Index < FCount then System.Move(FEntries^[Index + Delcount], FEntries^[Index], (FCount - Index) * SizeOf(Pointer));
if FCapacity - FCount >= GrowDelta(FCapacity) then SetCapacity(FCapacity - GrowDelta(FCapacity));
NotifyAfterCountChanged(FCount + Delcount, FCount);
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMArrayListBase.InsertIdx(const AKey: IUnknown): LongInt;
const cStrMethodName = 'InsertIdx';
function _InsertIdx(L, R: LongInt): LongInt;
var M: LongInt;
begin
//if not Assigned(CompareFunc) then Result := FCount else
if L >= R then Result := L else
begin
M := (L + R) shr 1;
case CompareEntries(AKey, EntryAsIntf(M)) of
crAEqualToB, crALessThanB: Result := _InsertIdx(L, M);
crAGreaterThanB: if L = M then Result := R else Result := _InsertIdx(M, R);
else
{$IFNDEF STANDALONE_COLLECTIONS}
raise EGMException.ObjError(RStrInvalidCompareResult, Self, cStrMethodName);
{$ELSE}
raise Exception.Create(GMStringJoin(GMStringJoin(GMObjName(Self), cStrErrNameSep, cStrMethodName), ': ', RStrInvalidCompareResult));
{$ENDIF}
end;
end;
end;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
if not FSorted then Result := FCount else Result := _InsertIdx(0, FCount);
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMArrayListBase.IndexOf(const AKey: IUnknown): LongInt;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
if not Sorted then
begin
for Result := 0 to FCount-1 do if CompareEntries(EntryAsIntf(Result), AKey) = crAEqualToB then Exit;
Result := cInvalidItemIdx;
end
else
begin
Result := InsertIdx(AKey);
if not IsValidIndex(Result) or (CompareEntries(EntryAsIntf(Result), AKey) <> crAEqualToB) then Result := cInvalidItemIdx;
end;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMArrayListBase.IndexOfNearest(const AKey: IUnknown): LongInt;
//var SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
CheckSorted;
Result := GMBoundedInt(InsertIdx(AKey), 0, FCount-1);
if not IsValidIndex(Result) then Result := cInvalidItemIdx;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMArrayListBase.Find(const AKey: IUnknown; out AEntry): Boolean;
var Idx: LongInt;// SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
Idx := IndexOf(AKey);
Result := IsValidIndex(Idx);
if Result then Pointer(AEntry) := FEntries^[Idx];
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMArrayListBase.FindNearest(const AKey: IUnknown; out AEntry): Boolean;
var Idx: LongInt;// SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
Idx := IndexOfNearest(AKey);
Result := IsValidIndex(Idx);
if Result then Pointer(AEntry) := FEntries^[Idx];
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMArrayListBase.RemoveByKey(const AKey: IUnknown): Boolean;
var Idx: LongInt;// SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
Idx := IndexOf(AKey);
Result := IsValidIndex(Idx);
if Result then RemoveByIdx(Idx);
finally
CriticalSection.LeaveCriticalSection;
end;
end;
procedure TGMArrayListBase.Reverse;
var i: LongInt; //SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
for i:=0 to FCount-1 shr 1 do Exchange(i, FCount-1-i);
finally
CriticalSection.LeaveCriticalSection;
end;
end;
procedure TGMArrayListBase.Rotate(const Delta: LongInt; const StartPos: LongInt = 0);
var Buffer: Pointer; BufferSize: LongInt; //SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
CheckUnsorted;
if Abs(Delta) >= FCount - StartPos then RaiseError(Format(RStrInvalidRotateDelta, [Delta]), Self, 'Rotate');
if StartPos >= FCount then RaiseError(Format(RStrInvalidRotateStartPos, [StartPos]), Self, 'Rotate');
BufferSize := Abs(Delta) * SizeOf(Pointer);
if Delta > 0 then
begin
GetMem(Buffer, BufferSize);
try
System.Move(FEntries^[FCount-Delta], Buffer^, BufferSize);
System.Move(FEntries^[StartPos], FEntries^[Delta+StartPos], (FCount-Delta-StartPos) * SizeOf(Pointer));
System.Move(Buffer^, FEntries^[StartPos], BufferSize);
finally
FreeMem(Buffer);
end;
end;
if Delta < 0 then
begin
GetMem(Buffer, BufferSize);
try
System.Move(FEntries^[StartPos], Buffer^, BufferSize);
System.Move(FEntries^[-Delta+StartPos], FEntries^[StartPos], (FCount+Delta-StartPos) * SizeOf(Pointer));
System.Move(Buffer^, FEntries^[FCount+Delta], BufferSize);
finally
FreeMem(Buffer);
end;
end;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
procedure TGMArrayListBase.Exchange(const Index1, Index2: LongInt);
const cStrMethodName = 'Exchange';
var TmpItem: Pointer; //SyncLock: IUnknown;
begin
// SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
if Index1 <> Index2 then
begin
CheckUnsorted;
GMCheckIntRange(RStrListIndex, Index1, 0, FCount-1, Self, cStrMethodName);
GMCheckIntRange(RStrListIndex, Index2, 0, FCount-1, Self, cStrMethodName);
TmpItem := FEntries^[Index1];
FEntries^[Index1] := FEntries^[Index2];
FEntries^[Index2] := TmpItem;
end;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
procedure TGMArrayListBase.Move(const SourceIdx, DestIdx: LongInt);
const cStrMethodName = 'MoveEntry';
var TmpItem: Pointer; //SyncLock: IUnknown;
begin
// SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
if SourceIdx <> DestIdx then
begin
CheckUnsorted;
GMCheckIntRange(RStrListIndex, SourceIdx, 0, FCount-1, Self, cStrMethodName);
GMCheckIntRange(RStrListIndex, DestIdx, 0, FCount-1, Self, cStrMethodName);
TmpItem := FEntries^[SourceIdx];
if SourceIdx < DestIdx then
System.Move(FEntries^[SourceIdx+1], FEntries^[SourceIdx], (DestIdx - SourceIdx) * SizeOf(Pointer))
else
System.Move(FEntries^[DestIdx], FEntries^[DestIdx+1], (SourceIdx - DestIdx) * SizeOf(Pointer));
FEntries^[DestIdx] := TmpItem;
end;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
procedure TGMArrayListBase.Sort;
procedure QuickSort(L, R: LongInt);
var i, j, m: LongInt; P: Pointer;
begin
i := L;
j := R;
m := (L + R) shr 1;
while i <= j do
begin
while CompareEntries(EntryAsIntf(i), EntryAsIntf(m)) = crALessThanB do Inc(i);
while CompareEntries(EntryAsIntf(j), EntryAsIntf(m)) = crAGreaterThanB do Dec(j);
if i <= j then
begin
if i <> j then // and CompareFunc(EntryAsIntf(i), EntryAsIntf(j)) <> crAEqualToB
begin
P := FEntries^[i]; FEntries^[i] := FEntries^[j]; FEntries^[j] := P; // <- exchange i <-> j
if m = i then m := j else if m = j then m := i; // <- if [m] has been exchanged update m
end;
Inc(i);
Dec(j);
end;
end;
if L < j then QuickSort(L, j);
if i < R then QuickSort(i, R);
end;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
if (FEntries <> nil) and (FCount > 0) then QuickSort(0, FCount-1);
finally
CriticalSection.LeaveCriticalSection;
end;
end;
{ ---------------------------------- }
{ ---- TGMArrayListBaseIterator ---- }
{ ---------------------------------- }
function TGMArrayListBaseIterator.NextEntry(out AEntry): Boolean;
begin
Result := (FCollection as TGMCollectionBase).IsValidIndex(FCurrentIdx);
if Result then begin AssignOutEntry(AEntry); if FReverse then Dec(FCurrentIdx) else Inc(FCurrentIdx); end;
end;
procedure TGMArrayListBaseIterator.Reset;
begin
if FReverse then FCurrentIdx := (FCollection as TGMCollectionBase).Count-1 else FCurrentIdx := 0;
end;
{ ---------------------------- }
{ ---- TGMObjArrayList ---- }
{ ---------------------------- }
Constructor TGMObjArrayList.Create(const AFreeEntries: Boolean = False;
const AAcceptDuplicates: Boolean = True;
const ASorted: Boolean = False;
const ACompareFunc: TGMIntfCompareFunc = nil;
const ARefLifeTime: Boolean = False);
begin
inherited Create(AAcceptDuplicates, ASorted, ACompareFunc, ARefLifeTime);
FFreeEntries := AFreeEntries;
end;
function TGMObjArrayList.CreateIterator(const AReverse, AConcurrentThreadLock: Boolean): IGMIterator;
begin
Result := TGMObjectListIterator.Create(Self, AConcurrentThreadLock, AReverse, True);
end;
function TGMObjArrayList.EntryAsIntf(const Index: LongInt): IUnknown;
begin
Result := GMObjAsIntf(FEntries^[Index]);
end;
procedure TGMObjArrayList.FreePointer(var Item: Pointer);
begin
FreeAndNil(TObject(Item));
end;
procedure TGMObjArrayList.SetOnAfterAddItem(const Value: TGMObjItemAddRemoveProc);
begin
OnAfterAddItem := Value;
end;
procedure TGMObjArrayList.NotifyAfterAddItem(const AItem: Pointer; const AIndex: LongInt);
begin
if Assigned(OnAfterAddItem) then OnAfterAddItem(Self, TObject(AItem), AIndex);
end;
procedure TGMObjArrayList.SetOnBeforeRemoveItem(const Value: TGMObjItemAddRemoveProc);
begin
OnBeforeRemoveItem := Value;
end;
procedure TGMObjArrayList.NotifyBeforeRemoveItem(const AItem: Pointer; const AIndex: LongInt);
begin
if Assigned(OnBeforeRemoveItem) then OnBeforeRemoveItem(Self, TObject(AItem), AIndex);
end;
function TGMObjArrayList.InsertAt(const AObj: TObject; const Index: LongInt; const AReplaceIfExists: Boolean): Boolean;
var doInsert: Boolean;
begin
// prevent GMObjAsIntf call when FAcceptDuplicates = true so objects without IUnknown can be added
doInsert := FAcceptDuplicates or not IsDuplicate(GMObjAsIntf(AObj), Index);
Result := doInsert or AReplaceIfExists;
if doInsert then
try InsertPointer(AObj, Index); except if FreeEntries then AObj.Free; raise; end
else
if AReplaceIfExists then
begin FreePointer(FEntries^[Index]); FEntries^[Index] := AObj; end;
end;
function TGMObjArrayList.ObjInsertIdx(const AObj: TObject): LongInt;
begin
// InsertIdx forces the added AObj to have the IUnknown interface, but this is only needed when sorted.
// Allow Interface-less objects to be added when not sorted
if not FSorted then Result := FCount else Result := InsertIdx(GMObjAsIntf(AObj));
end;
function TGMObjArrayList.Add(const AObj: TObject; const AReplaceIfExists: Boolean): TObject;
var Idx: LongInt; // SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
Idx := ObjInsertIdx(AObj);
if not InsertAt(AObj, Idx, AReplaceIfExists) and FreeEntries then begin AObj.Free; Result := nil; end else Result := AObj;
//begin if FreeEntries then AObj.Free; Result := nil; end else Result := AObj;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMObjArrayList.AddIdx(const AObj: TObject; const AReplaceIfExists: Boolean): LongInt;
//var SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
// InsertIdx forces the added AObj to have IUnknown, only mandatory when sorted. Allow normal objects to be added when not sorted
//if not FSorted then Result := FCount else Result := InsertIdx(GMObjAsIntf(AObj, cStrMethodName));
Result := ObjInsertIdx(AObj);
if not InsertAt(AObj, Result, AReplaceIfExists) then begin if FreeEntries then AObj.Free; Result := cInvalidItemIdx; end;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMObjArrayList.Insert(const AObj: TObject; const Index: LongInt; const AReplaceIfExists: Boolean): TObject;
//var SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
if FSorted then Result := Add(AObj, AReplaceIfExists) else
if not InsertAt(AObj, Index, AReplaceIfExists) and FreeEntries then begin AObj.Free; Result := nil; end else Result := AObj;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMObjArrayList.GetItem(const Index: LongInt): TObject;
const cStrMethodName = 'GetItem';
//var SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
GMCheckIntRange(RStrListIndex, Index, 0, FCount-1, Self, cStrMethodName);
Result := FEntries^[Index];
finally
CriticalSection.LeaveCriticalSection;
end;
end;
procedure TGMObjArrayList.SetItem(const Index: LongInt; const Value: TObject);
const cStrMethodName = 'GetItem';
//var SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
GMCheckIntRange(RStrListIndex, Index, 0, FCount-1, Self, cStrMethodName);
if FreeEntries then FreePointer(FEntries^[Index]);
FEntries^[Index] := Value;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMObjArrayList.First: TObject;
//var SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
if FCount = 0 then Result := nil else Result := GetItem(0);
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMObjArrayList.Last: TObject;
//var SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
if FCount = 0 then Result := nil else Result := GetItem(FCount - 1);
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMObjArrayList.IndexOfObj(const AObj: TObject): LongInt;
//var SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
Result := IndexOfPointer(AObj);
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMObjArrayList.RemoveByInstance(const AObj: TObject): Boolean;
var Idx: LongInt;
begin
CriticalSection.EnterCriticalSection;
try
Idx := IndexOfObj(AObj);
Result := IsValidIndex(Idx);
if Result then RemoveByIdx(Idx);
finally
CriticalSection.LeaveCriticalSection;
end;
end;
{function TGMObjArrayList.FindObj(const Obj: TObject; var Index: LongInt): Boolean;
//var SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
Index := IndexOfObj(Obj);
Result := IsValidIndex(Index);
finally
CriticalSection.LeaveCriticalSection;
end;
end;}
{ ------------------------------- }
{ ---- TGMObjectListIterator ---- }
{ ------------------------------- }
procedure TGMObjectListIterator.AssignOutEntry(out AEntry);
begin
TObject(AEntry) := (FCollection as TGMObjArrayList)[FCurrentIdx];
end;
{ -------------------------- }
{ ---- TGMIntfArrayList ---- }
{ -------------------------- }
Constructor TGMIntfArrayList.Create(const AAcceptDuplicates: Boolean = True;
const ASorted: Boolean = False;
const ACompareFunc: TGMIntfCompareFunc = nil;
const ARefLifeTime: Boolean = True);
begin
inherited Create(AAcceptDuplicates, ASorted, ACompareFunc, ARefLifeTime);
FFreeEntries := True;
end;
function TGMIntfArrayList.CreateIterator(const AReverse, AConcurrentThreadLock: Boolean): IGMIterator;
begin
Result := TGMIntfArrayListIterator.Create(Self, AConcurrentThreadLock, AReverse, True);
end;
function TGMIntfArrayList.EntryAsIntf(const Index: LongInt): IUnknown;
begin
Result := IUnknown(FEntries^[Index]);
end;
procedure TGMIntfArrayList.FreePointer(var Item: Pointer);
begin
//if Item <> nil then IUnknown(Item)._Release;
if Item <> nil then IUnknown(Item) := nil; // <- does a IUnknown(Item)._Release
end;
procedure TGMIntfArrayList.SetOnAfterAddItem(const Value: TGMIntfItemAddRemoveProc);
begin
OnAfterAddItem := Value;
end;
procedure TGMIntfArrayList.NotifyAfterAddItem(const AItem: Pointer; const AIndex: LongInt);
begin
if Assigned(OnAfterAddItem) then OnAfterAddItem(Self, IUnknown(AItem), AIndex);
end;
procedure TGMIntfArrayList.SetOnBeforeRemoveItem(const Value: TGMIntfItemAddRemoveProc);
begin
OnBeforeRemoveItem := Value;
end;
procedure TGMIntfArrayList.NotifyBeforeRemoveItem(const AItem: Pointer; const AIndex: LongInt);
begin
if Assigned(OnBeforeRemoveItem) then OnBeforeRemoveItem(Self, IUnknown(AItem), AIndex);
end;
function TGMIntfArrayList.InsertAt(const AIntf: IUnknown; const Index: LongInt; const AReplaceIfExists: Boolean): Boolean;
var unk: IUnknown; doInsert: Boolean;
begin
GMQueryInterface(AIntf, IUnknown, unk); // <- Always add the real IUnknown representation for proper object identifications and iterator return values
doInsert := FAcceptDuplicates or not IsDuplicate(unk, Index);
Result := doInsert or AReplaceIfExists;
if doInsert then
begin InsertPointer(Pointer(unk), Index); unk._AddRef; end
else
if AReplaceIfExists then
begin FreePointer(FEntries^[Index]); FEntries^[Index] := Pointer(unk); unk._AddRef; end;
end;
function TGMIntfArrayList.AddIdx(const AIntf: IUnknown; const AReplaceIfExists: Boolean): LongInt;
var ItemHolder: IUnknown; // SyncLock
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
// Without an additional reference stack cleanup after return of InsertIdx may free a newly
// created object (with refcount = 0) and the call to InsertAt would cause an access violation
// And ItemHolder will cleanup a refcount = 0 AIntf in case of exceptions
ItemHolder := AIntf;
Result := InsertIdx(AIntf);
if not InsertAt(AIntf, Result, AReplaceIfExists) then Result := cInvalidItemIdx;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMIntfArrayList.Add(const AIntf: IUnknown; const AReplaceIfExists: Boolean): IUnknown;
var ItemHolder: IUnknown; // SyncLock
begin
// SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
// Without an additional reference stack cleanup after return of InsertIdx may free a newly
// created object (with refcount = 0) and the call to InsertAt would cause an access violation
// And ItemHolder will cleanup a refcount = 0 AIntf in case of exceptions
ItemHolder := AIntf;
if InsertAt(AIntf, InsertIdx(AIntf), AReplaceIfExists) then Result := AIntf; // else Result := nil
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMIntfArrayList.Insert(const AIntf: IUnknown; const Index: LongInt; const AReplaceIfExists: Boolean): IUnknown;
var ItemHolder: IUnknown; // SyncLock
begin
// SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
// ItemHolder will cleanup a refcount = 0 AIntf in case of exceptions
CriticalSection.EnterCriticalSection;
try
ItemHolder := AIntf;
if FSorted then Result := Add(AIntf, AReplaceIfExists) else if InsertAt(AIntf, Index, AReplaceIfExists) then Result := AIntf; // else Result := nil
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMIntfArrayList.Find(const AKey: IUnknown; out AEntry): Boolean;
var Idx: LongInt;// SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
Idx := IndexOf(AKey);
Result := IsValidIndex(Idx);
if Result then IUnknown(AEntry) := IUnknown(FEntries^[Idx]);
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMIntfArrayList.FindNearest(const AKey: IUnknown; out AEntry): Boolean;
var Idx: LongInt;// SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
Idx := IndexOfNearest(AKey);
Result := IsValidIndex(Idx);
if Result then IUnknown(AEntry) := IUnknown(FEntries^[Idx]);
finally
CriticalSection.LeaveCriticalSection;
end;
end;
{function TGMIntfArrayList.Remove(const Item: IUnknown): LongInt;
//var SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
Result := IndexOfObj(Item);
if Result <> cInvalidItemIdx then Delete(Result);
finally
CriticalSection.LeaveCriticalSection;
end;
end;}
function TGMIntfArrayList.GetItem(const Index: LongInt): IUnknown;
const cStrMethodName = 'GetItem';
//var SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
GMCheckIntRange(RStrListIndex, Index, 0, FCount-1, Self, cStrMethodName);
Result := IUnknown(FEntries^[Index]);
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMIntfArrayList.First: IUnknown;
//var SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
if FCount = 0 then Result := nil else Result := GetItem(0);
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMIntfArrayList.Last: IUnknown;
//var SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
if FCount = 0 then Result := nil else Result := GetItem(FCount - 1);
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMIntfArrayList.IndexOfObj(const AIntf: IUnknown): LongInt;
//var SyncLock: IUnknown;
var PIUnk: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
if GMQueryInterface(AIntf, IUnknown, PIUnk) then // <- Use the real IUnknown representation for proper object identification!
Result := IndexOfPointer(Pointer(PIUnk))
else
Result := cInvalidItemIdx;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMIntfArrayList.RemoveByInstance(const AIntf: IUnknown): Boolean;
var Idx: LongInt;
begin
CriticalSection.EnterCriticalSection;
try
Idx := IndexOfObj(AIntf);
Result := IsValidIndex(Idx);
if Result then RemoveByIdx(Idx);
finally
CriticalSection.LeaveCriticalSection;
end;
end;
{function TGMIntfArrayList.FindObj(const Intf: IUnknown; var Index: LongInt): Boolean;
//var SyncLock: IUnknown;
begin
//SyncLock := TGMCriticalSectionLock.Create(FCriticalSection);
CriticalSection.EnterCriticalSection;
try
Index := IndexOfObj(Intf);
Result := IsValidIndex(Index);
finally
CriticalSection.LeaveCriticalSection;
end;
end;}
{ ---------------------------------- }
{ ---- TGMIntfArrayListIterator ---- }
{ ---------------------------------- }
procedure TGMIntfArrayListIterator.AssignOutEntry(out AEntry);
begin
IUnknown(AEntry) := (FCollection as TGMIntfArrayList)[FCurrentIdx];
end;
{ ---------------------------- }
{ ---- TGMAvlTreeNodeBase ---- }
{ ---------------------------- }
function TGMAvlTreeNodeBase.TreeHeight: LongInt;
var LeftHeight, RightHeight: LongInt;
begin
if Left <> nil then LeftHeight := Left.TreeHeight + 1 else LeftHeight := 0;
if Right <> nil then RightHeight := Right.TreeHeight + 1 else RightHeight := 0;
Result := Max(LeftHeight, RightHeight);
end;
function TGMAvlTreeNodeBase.CalcBalance: LongInt;
var LeftHeight, RightHeight: LongInt;
begin
if Left <> nil then LeftHeight := Left.TreeHeight + 1 else LeftHeight := 0;
if Right <> nil then RightHeight := Right.TreeHeight + 1 else RightHeight := 0;
Result := RightHeight - LeftHeight;
end;
procedure TGMAvlTreeNodeBase.ResetMembers;
begin
Parent := nil;
Left := nil;
Right := nil;
Balance := 0;
//Data := nil;
end;
function TGMAvlTreeNodeBase.GetChild(const AIdx: TGMAvlTreeNodeDirection): TGMAvlTreeNodeBase;
begin
case AIdx of
tndLeft: Result := Left;
tndRight: Result := Right;
else Result := nil;
end;
end;
procedure TGMAvlTreeNodeBase.SetChild(const AIdx: TGMAvlTreeNodeDirection; const AValue: TGMAvlTreeNodeBase);
begin
case AIdx of
tndLeft: Left := AValue;
tndRight: Right := AValue;
end;
end;
{ ------------------------ }
{ ---- TGMAvlTreeBase ---- }
{ ------------------------ }
procedure TGMAvlTreeBase.Clear(const ANotify: Boolean);
//var OldCount: LongInt;
procedure FreeNodeMemory(ANode: TGMAvlTreeNodeBase);
begin
if ANode <> nil then begin
if ANode.Left <> nil then FreeNodeMemory(ANode.Left);
if ANode.Right <> nil then FreeNodeMemory(ANode.Right);
FreeNode(ANode);
end;
end;
begin
if IsEmpty then Exit;
FreeNodeMemory(Root);
Root := nil;
if ANotify then NotifyAfterCountChanged(FCount, 0);
FCount := 0;
end;
function TGMAvlTreeBase.CreateTreeNode: TGMAvlTreeNodeBase;
begin
Result := TreeNodeCreateClass.Create;
end;
procedure TGMAvlTreeBase.FreeNode(const ANode: TGMAvlTreeNodeBase);
begin
if ANode <> nil then ANode.Free;
end;
function TGMAvlTreeBase.AddNode(const ANode: TGMAvlTreeNodeBase): Boolean;
var UnkNodeData: IUnknown;
begin
CriticalSection.EnterCriticalSection;
try
ANode.Left := nil;
ANode.Right := nil;
if Root = nil then begin Root := ANode; ANode.Parent := nil; end else
begin
UnkNodeData := ANode.GetDataAsIntf;
ANode.Parent := FindInsertPos(UnkNodeData);
if ANode.Parent = nil then begin UnkNodeData := nil; FreeNode(ANode); Result := False; Exit; end; // <- Is duplicate but FAcceptDuplicates = False
case CompareEntries(UnkNodeData, ANode.Parent.GetDataAsIntf) of
crALessThanB: ANode.Parent.Left := ANode;
//crAEqualToB: if FAcceptDuplicates then ANode.Parent.Right := ANode else begin FreeNode(ANode); Exit; end;
//crAGreaterThanB: ANode.Parent.Right := ANode;
else ANode.Parent.Right := ANode;
end;
BalanceAfterInsert(ANode);
end;
Inc(FCount);
NotifyAfterCountChanged(FCount-1, FCount);
Result := True;
// CheckIntegrity;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMAvlTreeBase.FirstNode: TGMAvlTreeNodeBase;
begin
CriticalSection.EnterCriticalSection;
try
Result := Root;
if Result <> nil then while Result.Left <> nil do Result := Result.Left;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMAvlTreeBase.LastNode: TGMAvlTreeNodeBase;
begin
CriticalSection.EnterCriticalSection;
try
Result := Root;
if Result <> nil then while Result.Right <> nil do Result := Result.Right;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function OppositeDirection(const ADirection: TGMAvlTreeNodeDirection): TGMAvlTreeNodeDirection;
begin
Result := TGMAvlTreeNodeDirection((Ord(ADirection) + 1) mod (Ord(High(ADirection)) + 1));
end;
function TGMAvlTreeBase.Rotate(const ANode: TGMAvlTreeNodeBase; const ADirection: TGMAvlTreeNodeDirection): TGMAvlTreeNodeBase;
//const cBalanceInc: array [TGMAvlTreeNodeDirection] of LongInt = (1, -1);
var PrntNode: TGMAvlTreeNodeBase; OppDir, d: TGMAvlTreeNodeDirection;
begin
Result := ANode;
if ANode = nil then Exit;
OppDir := OppositeDirection(ADirection);
Result := ANode[OppDir];
if Result = nil then Exit;
ANode[OppDir] := Result[ADirection];
if Result[ADirection] <> nil then Result[ADirection].Parent := ANode;
PrntNode := Anode.Parent;
Result[ADirection] := ANode;
ANode.Parent := Result;
Result.Parent := PrntNode;
if PrntNode = nil then Root := Result else
for d:=Low(d) to High(d) do if PrntNode[d] = ANode then
begin
PrntNode[d] := Result;
//if Result.Balance <> 0 then Inc(PrntNode.Balance, cBalanceInc[d]);
Break;
end;
//ANode.Balance := cBalanceInc[ADirection] - Result.Balance;
//Inc(Result.Balance, cBalanceInc[ADirection]);
end;
function TGMAvlTreeBase.DoubleRotate(const ANode: TGMAvlTreeNodeBase; const ADirection: TGMAvlTreeNodeDirection): TGMAvlTreeNodeBase;
var OppDir: TGMAvlTreeNodeDirection;
begin
Result := ANode;
if ANode = nil then Exit;
OppDir := OppositeDirection(ADirection);
Rotate(ANode[OppDir], OppDir);
Result := Rotate(ANode, ADirection);
end;
procedure TGMAvlTreeBase.BalanceAfterInsert(const ANode: TGMAvlTreeNodeBase);
const cBalanceInc: array [TGMAvlTreeNodeDirection] of LongInt = (-1, 1); cStrMethodName = 'BalanceAfterInsert';
var ParentNode, ChildNode: TGMAvlTreeNodeBase; Dir, OppDir: TGMAvlTreeNodeDirection;
begin
if (ANode = nil) or (ANode.Parent = nil) then Exit;
ParentNode := ANode.Parent;
if ParentNode.Left = ANode then Dir := tndLeft else
if ParentNode.Right = ANode then Dir := tndRight else
{$IFNDEF STANDALONE_COLLECTIONS}
raise EGMException.ObjError(RStrNodeParentLinkError, ANode, cStrMethodName);
{$ELSE}
raise Exception.Create(GMStringJoin(GMStringJoin(GMObjName(ANode), cStrErrNameSep, cStrMethodName), ': ', RStrNodeParentLinkError));
{$ENDIF}
OppDir := OppositeDirection(Dir);
Inc(ParentNode.Balance, cBalanceInc[Dir]);
if ParentNode.Balance = 0 then Exit;
if ParentNode.Balance = cBalanceInc[Dir] then begin BalanceAfterInsert(ParentNode); Exit; end;
if ANode.Balance = cBalanceInc[Dir] then
begin
Rotate(Anode.Parent, OppDir);
ANode.Balance := 0;
ParentNode.Balance := 0;
end
else
begin
ChildNode := ANode[OppDir];
DoubleRotate(Anode.Parent, OppDir);
case Dir of
tndLeft: if ChildNode.Balance <= 0 then ANode.Balance := 0 else ANode.Balance := -1;
tndRight: if ChildNode.Balance >= 0 then ANode.Balance := 0 else ANode.Balance := 1;
end;
if ChildNode.Balance = cBalanceInc[Dir] then ParentNode.Balance := cBalanceInc[OppDir] else ParentNode.Balance := 0;
ChildNode.Balance := 0;
end;
end;
procedure TGMAvlTreeBase.BalanceAfterDelete(const ANode: TGMAvlTreeNodeBase);
var NodeParent, RightChild, RightLeftchild, LeftChild, LeftRightChild: TGMAvlTreeNodeBase;
begin
if (ANode = nil) then Exit;
if ((ANode.Balance = 1) or (ANode.Balance = -1)) then Exit;
NodeParent := ANode.Parent;
if ANode.Balance = 0 then begin
// Treeheight has decreased by one
if NodeParent <> nil then begin
if NodeParent.Left = ANode then Inc(NodeParent.Balance) else Dec(NodeParent.Balance);
BalanceAfterDelete(NodeParent);
end;
Exit;
end;
if ANode.Balance = 2 then begin
// Node is overweighted to the right
RightChild := ANode.Right;
if RightChild.Balance >= 0 then begin
// RightChild.Balance is 0 or -1
Rotate(ANode, tndLeft);
ANode.Balance := 1 - RightChild.Balance;
Dec(RightChild.Balance);
BalanceAfterDelete(RightChild);
end else begin
// RightChild.Balance is -1
RightLeftchild := RightChild.Left;
DoubleRotate(ANode, tndLeft);
if RightLeftchild.Balance <= 0 then ANode.Balance := 0 else ANode.Balance := -1;
if RightLeftchild.Balance >= 0 then RightChild.Balance := 0 else RightChild.Balance := 1;
RightLeftchild.Balance := 0;
BalanceAfterDelete(RightLeftchild);
end;
end else begin
// Node.Balance is -2
// Node is overweighted to the left
LeftChild := ANode.Left;
if (LeftChild.Balance <= 0) then begin
Rotate(ANode, tndRight);
ANode.Balance := -1 - LeftChild.Balance;
Inc(LeftChild.Balance);
BalanceAfterDelete(LeftChild);
end else begin
// LeftChild.Balance is 1
LeftRightChild := LeftChild.Right;
DoubleRotate(ANode, tndRight);
if LeftRightChild.Balance >= 0 then ANode.Balance := 0 else ANode.Balance := 1;
if LeftRightChild.Balance <= 0 then LeftChild.Balance := 0 else LeftChild.Balance := -1;
LeftRightChild.Balance := 0;
BalanceAfterDelete(LeftRightChild);
end;
end;
end;
procedure TGMAvlTreeBase.DeleteNode(const ANode: TGMAvlTreeNodeBase);
var OldParent, OldLeft, OldRight, Successor, OldSuccParent, OldSuccLeft, OldSuccRight: TGMAvlTreeNodeBase; OldBalance: LongInt;
begin
CriticalSection.EnterCriticalSection;
try
OldParent := ANode.Parent;
OldBalance := ANode.Balance;
ANode.Parent := nil;
ANode.Balance := 0;
if ((ANode.Left = nil) and (ANode.Right = nil)) then begin
// Node is Leaf (no children)
if OldParent <> nil then begin
// Node has parent
if OldParent.Left = ANode then
begin OldParent.Left := nil; Inc(OldParent.Balance); end // <- Node is left Son of OldParent
else
begin OldParent.Right := nil; Dec(OldParent.Balance); end; // <- Node is right Son of OldParent
BalanceAfterDelete(OldParent);
end else Root := nil; // <- Node is the only node in the tree
Dec(FCount);
FreeNode(ANode);
NotifyAfterCountChanged(FCount+1, FCount);
Exit;
end;
if ANode.Right = nil then begin
// Left is only son
// and because DelNode is AVL, Right has no childrens
// replace DelNode with Left
OldLeft := ANode.Left;
ANode.Left := nil;
OldLeft.Parent := OldParent;
if (OldParent <> nil) then begin
if (OldParent.Left=ANode) then
begin OldParent.Left := OldLeft; Inc(OldParent.Balance); end
else
begin OldParent.Right := OldLeft; Dec(OldParent.Balance); end;
BalanceAfterDelete(OldParent);
end else begin
Root := OldLeft;
end;
Dec(FCount);
FreeNode(ANode);
NotifyAfterCountChanged(FCount+1, FCount);
Exit;
end;
if ANode.Left = nil then begin
// Right is only son
// and because DelNode is AVL, Left has no childrens
// replace DelNode with Right
OldRight := ANode.Right;
ANode.Right := nil;
OldRight.Parent := OldParent;
if (OldParent <> nil) then begin
if (OldParent.Left=ANode) then
begin OldParent.Left := OldRight; Inc(OldParent.Balance); end
else
begin OldParent.Right := OldRight; Dec(OldParent.Balance); end;
BalanceAfterDelete(OldParent);
end else begin
Root := OldRight;
end;
Dec(FCount);
FreeNode(ANode);
NotifyAfterCountChanged(FCount+1, FCount);
Exit;
end;
// DelNode has both: Left and Right
// Replace ANode with symmetric Successor
Successor := SuccessorNode(ANode);
OldLeft := ANode.Left;
OldRight := ANode.Right;
OldSuccParent := Successor.Parent;
OldSuccLeft := Successor.Left;
OldSuccRight := Successor.Right;
ANode.Balance := Successor.Balance;
Successor.Balance := OldBalance;
if OldSuccParent <> ANode then begin
// at least one node between ANode and Successor
ANode.Parent := Successor.Parent;
if OldSuccParent.Left = Successor then OldSuccParent.Left := ANode else OldSuccParent.Right := ANode;
Successor.Right := OldRight;
OldRight.Parent := Successor;
end else begin
// Successor is right son of ANode
ANode.Parent := Successor;
Successor.Right := ANode;
end;
Successor.Left := OldLeft;
if OldLeft <> nil then OldLeft.Parent := Successor;
Successor.Parent := OldParent;
ANode.Left := OldSuccLeft;
if ANode.Left <> nil then ANode.Left.Parent := ANode;
ANode.Right := OldSuccRight;
if ANode.Right <> nil then ANode.Right.Parent := ANode;
if OldParent <> nil then begin
if (OldParent.Left=ANode) then OldParent.Left := Successor else OldParent.Right := Successor;
end else
Root := Successor;
DeleteNode(ANode); // <- recursive call!
// CheckIntegrity;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMAvlTreeBase.RemoveByKey(const AKey: IUnknown): Boolean;
var Node: TGMAvlTreeNodeBase;
begin
CriticalSection.EnterCriticalSection;
try
Node := FindNode(AKey);
Result := Node <> nil;
if Result then DeleteNode(Node);
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMAvlTreeBase.RemoveByInstance(const AInstance): Boolean;
var node: TGMAvlTreeNodeBase;
begin
CriticalSection.EnterCriticalSection;
try
node := FirstNode; Result := False;
while node <> nil do
begin
if node.IsDataInstance(AInstance) then begin DeleteNode(node); Result := True; Break; end;
node := SuccessorNode(node);
end;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMAvlTreeBase.FindNode(const AKey: IUnknown): TGMAvlTreeNodeBase;
begin
CriticalSection.EnterCriticalSection;
try
Result := Root;
while Result <> nil do
case CompareEntries(AKey, Result.GetDataAsIntf) of
crALessThanB: Result := Result.Left;
crAEqualToB: Break;
crAGreaterThanB: Result := Result.Right;
end;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMAvlTreeBase.FindNearestNode(const AKey: IUnknown): TGMAvlTreeNodeBase;
begin
CriticalSection.EnterCriticalSection;
try
Result := Root;
while Result <> nil do
case CompareEntries(AKey, Result.GetDataAsIntf) of
crALessThanB: if Result.Left <> nil then Result := Result.Left else Break;
crAEqualToB: Break;
crAGreaterThanB: if Result.Right <> nil then Result := Result.Right else Break;
end;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMAvlTreeBase.FindInsertPos(const AKey: IUnknown): TGMAvlTreeNodeBase;
Label GreaterThanCase;
begin
CriticalSection.EnterCriticalSection;
try
Result := Root;
while Result <> nil do
case CompareEntries(AKey, Result.GetDataAsIntf) of
crALessThanB: if Result.Left <> nil then Result := Result.Left else Break;
crAEqualToB: if FAcceptDuplicates then goto GreaterThanCase else begin Result := nil; Break; end;
crAGreaterThanB: GreaterThanCase: if Result.Right <> nil then Result := Result.Right else Break;
end;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMAvlTreeBase.SuccessorNode(const ANode: TGMAvlTreeNodeBase): TGMAvlTreeNodeBase;
begin
CriticalSection.EnterCriticalSection;
try
if ANode = nil then begin Result := nil; Exit; end;
Result := ANode.Right;
if Result <> nil then begin while Result.Left <> nil do Result := Result.Left; end
else begin
Result := ANode;
while (Result.Parent <> nil) and (Result.Parent.Right = Result) do Result := Result.Parent;
Result := Result.Parent;
end;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMAvlTreeBase.PredecessorNode(const ANode: TGMAvlTreeNodeBase): TGMAvlTreeNodeBase;
begin
CriticalSection.EnterCriticalSection;
try
if ANode = nil then begin Result := nil; Exit; end;
Result := ANode.Left;
if Result <> nil then begin while Result.Right <> nil do Result := Result.Right; end
else begin
Result := ANode;
while (Result.Parent <> nil) and (Result.Parent.Left = Result) do Result := Result.Parent;
Result := Result.Parent;
end;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
procedure TGMAvlTreeBase.CheckIntegrity;
var checkCount: integer;
procedure RaiseIntegrityException(const AMsg: String);
begin
raise Exception.Create(RStrAvlTreeIntegrityViolation + ': ' + AMsg);
end;
procedure CheckNode(ANode: TGMAvlTreeNodeBase);
var LeftHeight, RightHeight: integer;
begin
if ANode = nil then Exit;
Inc(checkCount);
// Check left child
if ANode.Left <> nil then begin
if ANode.Left.Parent <> ANode then RaiseIntegrityException(RStrLeftChildsParentNotUs);
if CompareEntries(ANode.Left.GetDataAsIntf, ANode.GetDataAsIntf) = crAGreaterThanB then
RaiseIntegrityException(RStrLeftChildGreaterThanUs);
CheckNode(ANode.Left);
end;
// Check right child
if ANode.Right <> nil then begin
if ANode.Right.Parent <> ANode then RaiseIntegrityException(RStrRightChildsParentNotUs);
if CompareEntries(ANode.GetDataAsIntf, ANode.Right.GetDataAsIntf) = crAGreaterThanB then
RaiseIntegrityException(RStrWeGreaterThanRightChild);
CheckNode(ANode.Right);
end;
// Check balance
if ANode.Left <> nil then LeftHeight := ANode.Left.TreeHeight + 1 else LeftHeight := 0;
if ANode.Right <> nil then RightHeight := ANode.Right.TreeHeight + 1 else RightHeight := 0;
if ANode.Balance <> (RightHeight-LeftHeight) then
RaiseIntegrityException(Format(RStrWrongNodeBalanceFmt, [ANode.Balance, RightHeight-LeftHeight]));
end;
begin
CriticalSection.EnterCriticalSection;
try
checkCount := 0;
CheckNode(Root);
if FCount <> checkCount then RaiseIntegrityException(Format(RStrWrongNodeCountFmt, [FCount, checkCount]));
finally
CriticalSection.LeaveCriticalSection;
end;
end;
procedure TGMAvlTreeBase.SetCompareFunc(const AValue: TGMIntfCompareFunc);
var Nodes: array of TGMAvlTreeNodeBase; Node: TGMAvlTreeNodeBase; i, OldCount: integer;
begin
CriticalSection.EnterCriticalSection;
try
if Addr(FCompareFunc) = Addr(AValue) then Exit;
if Count = 0 then FCompareFunc := AValue else
begin
OldCount := Count;
SetLength(Nodes, OldCount);
Node := FirstNode;
i := Low(Nodes);
while Node <> nil do begin Nodes[i] := Node; Inc(i); Node := SuccessorNode(Node); end;
Root := nil; FCount := 0;
FCompareFunc := AValue;
for i:=Low(Nodes) to High(Nodes) do AddNode(Nodes[i]);
end;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
{ -------------------------------- }
{ ---- TGMAvlTreeIteratorBase ---- }
{ -------------------------------- }
function TGMAvlTreeIteratorBase.NextEntry(out AEntry): Boolean;
begin
Result := FCurrentNode <> nil;
if Result then
begin
AssignOutEntry(AEntry);
if FReverse then
FCurrentNode := (FCollection as TGMAvlTreeBase).PredecessorNode(FCurrentNode)
else
FCurrentNode := (FCollection as TGMAvlTreeBase).SuccessorNode(FCurrentNode);
end;
end;
procedure TGMAvlTreeIteratorBase.Reset;
begin
if FReverse then
FCurrentNode := (FCollection as TGMAvlTreeBase).LastNode
else
FCurrentNode := (FCollection as TGMAvlTreeBase).FirstNode;
end;
{ --------------------------- }
{ ---- TGMAvlObjTreeNode ---- }
{ --------------------------- }
function TGMAvlObjTreeNode.GetDataAsIntf: IUnknown;
begin
Result := GMObjAsIntf(Data);
end;
function TGMAvlObjTreeNode.IsDataInstance(const AInstance): Boolean;
begin
Result := Data = TObject(AInstance);
end;
{ ----------------------- }
{ ---- TGMAvlObjTree ---- }
{ ----------------------- }
constructor TGMAvlObjTree.Create(const AFreeEntries: Boolean; const AAcceptDuplicates: Boolean;
const ACompareFunc: TGMIntfCompareFunc; const ARefLifeTime: Boolean);
begin
inherited Create(AAcceptDuplicates, ACompareFunc, ARefLifeTime);
FFreeEntries := AFreeEntries;
end;
function TGMAvlObjTree.TreeNodeCreateClass: TGMAvlTreeNodeClass;
begin
Result := TGMAvlObjTreeNode;
end;
function TGMAvlObjTree.CreateIterator(const AReverse, AConcurrentThreadLock: Boolean): IGMIterator;
begin
Result := TGMAvlObjectTreeIterator.Create(Self, AConcurrentThreadLock, AReverse, True);
end;
function TGMAvlObjTree.Add(const ANewEntry: TObject; const AReplaceIfExists: Boolean): TObject;
var NewNode: TGMAvlTreeNodeBase;
begin
NewNode := CreateTreeNode;
(NewNode as TGMAvlObjTreeNode).Data := ANewEntry;
if AddNode(NewNode) then Result := ANewEntry else Result := nil;
end;
procedure TGMAvlObjTree.FreeNode(const ANode: TGMAvlTreeNodeBase);
begin
if FFreeEntries and ((ANode as TGMAvlObjTreeNode).Data <> nil) then TGMAvlObjTreeNode(ANode).Data.Free; //FreeAndNil((ANode as TGMAvlObjTreeNode).Data); // .Free;
inherited FreeNode(ANode);
end;
function TGMAvlObjTree.Find(const AKey: IUnknown; out AEntry): Boolean;
var Node: TGMAvlTreeNodeBase;
begin
Node := FindNode(AKey);
Result := (Node is TGMAvlObjTreeNode) and (TGMAvlObjTreeNode(Node).Data <> nil);
if Result then TObject(AEntry) := TGMAvlObjTreeNode(Node).Data;
end;
function TGMAvlObjTree.FindNearest(const AKey: IUnknown; out AEntry): Boolean;
var Node: TGMAvlTreeNodeBase;
begin
Node := FindNearestNode(AKey);
Result := (Node is TGMAvlObjTreeNode) and (TGMAvlObjTreeNode(Node).Data <> nil);
if Result then TObject(AEntry) := TGMAvlObjTreeNode(Node).Data;
end;
function TGMAvlObjTree.RemoveByInstance(const AObj: TObject): Boolean;
begin
Result := inherited RemoveByInstance(AObj);
end;
function TGMAvlObjTree.First: TObject;
var Node: TGMAvlTreeNodeBase;
begin
Node := FirstNode;
if Node = nil then Result := nil else Result := (Node as TGMAvlObjTreeNode).Data;
end;
function TGMAvlObjTree.Last: TObject;
var Node: TGMAvlTreeNodeBase;
begin
Node := LastNode;
if Node = nil then Result := nil else Result := (Node as TGMAvlObjTreeNode).Data;
end;
{ ---------------------------------- }
{ ---- TGMAvlObjectTreeIterator ---- }
{ ---------------------------------- }
procedure TGMAvlObjectTreeIterator.AssignOutEntry(out AEntry);
begin
TObject(AEntry) := (FCurrentNode as TGMAvlObjTreeNode).Data;
end;
{ ---------------------------- }
{ ---- TGMAvlIntfTreeNode ---- }
{ ---------------------------- }
function TGMAvlIntfTreeNode.GetDataAsIntf: IUnknown;
begin
Result := Data;
end;
function TGMAvlIntfTreeNode.IsDataInstance(const AInstance): Boolean;
var Unk: IUnknown;
begin
GMQueryInterface(IUnknown(AInstance), IUnknown, unk); // <- Use the real IUnknown representation for proper object identifications
Result := Data = unk;
end;
{ ------------------------ }
{ ---- TGMAvlIntfTree ---- }
{ ------------------------ }
function TGMAvlIntfTree.TreeNodeCreateClass: TGMAvlTreeNodeClass;
begin
Result := TGMAvlIntfTreeNode;
end;
function TGMAvlIntfTree.CreateIterator(const AReverse, AConcurrentThreadLock: Boolean): IGMIterator;
begin
Result := TGMAvlIntfTreeIterator.Create(Self, AConcurrentThreadLock, AReverse, True);
end;
function TGMAvlIntfTree.Add(const ANewEntry: IUnknown; const AReplaceIfExists: Boolean): IUnknown;
var NewNode: TGMAvlTreeNodeBase; unk: IUnknown;
begin
GMQueryInterface(ANewEntry, IUnknown, unk); // <- Always add the real IUnknown representation for proper object identifications
NewNode := CreateTreeNode;
(NewNode as TGMAvlIntfTreeNode).Data := unk;
if AddNode(NewNode) then Result := ANewEntry;
end;
function TGMAvlIntfTree.Find(const AKey: IUnknown; out AEntry): Boolean;
var Node: TGMAvlTreeNodeBase;
begin
Node := FindNode(AKey);
Result := (Node is TGMAvlIntfTreeNode) and (TGMAvlIntfTreeNode(Node).Data <> nil);
if Result then IUnknown(AEntry) := TGMAvlIntfTreeNode(Node).Data;
end;
function TGMAvlIntfTree.FindNearest(const AKey: IUnknown; out AEntry): Boolean;
var Node: TGMAvlTreeNodeBase;
begin
Node := FindNearestNode(AKey);
Result := (Node is TGMAvlIntfTreeNode) and (TGMAvlIntfTreeNode(Node).Data <> nil);
if Result then IUnknown(AEntry) := TGMAvlIntfTreeNode(Node).Data;
end;
function TGMAvlIntfTree.RemoveByInstance(const AIntf: IUnknown): Boolean;
var unk: IUnknown;
begin
Result := GMQueryInterface(AIntf, IUnknown, unk) and inherited RemoveByInstance(unk); // <- use real Iunknown representation for proper object identification
end;
function TGMAvlIntfTree.First: IUnknown;
var Node: TGMAvlTreeNodeBase;
begin
Node := FirstNode;
if Node = nil then Result := nil else Result := (Node as TGMAvlIntfTreeNode).Data;
end;
function TGMAvlIntfTree.Last: IUnknown;
var Node: TGMAvlTreeNodeBase;
begin
Node := LastNode;
if Node = nil then Result := nil else Result := (Node as TGMAvlIntfTreeNode).Data;
end;
{ -------------------------------- }
{ ---- TGMAvlIntfTreeIterator ---- }
{ -------------------------------- }
procedure TGMAvlIntfTreeIterator.AssignOutEntry(out AEntry);
begin
IUnknown(AEntry) := (FCurrentNode as TGMAvlIntfTreeNode).Data;
end;
{ ---------------------------- }
{ ---- TGMHashEntryBucket ---- }
{ ---------------------------- }
constructor TGMHashEntryBucket.Create(const AHashTable: TGMHashTableBase; const ARefLifeTime: Boolean); // ; const AHashBitCount: Byte;
begin
inherited Create(ARefLifeTime);
FHashTable := AHashTable;
//FHashBitCount := AHashBitCount;
end;
destructor TGMHashEntryBucket.Destroy;
begin
Clear(True); SetCapacity(0); inherited;
end;
procedure TGMHashEntryBucket.Clear(const AFreeEntries: Boolean);
var i: LongInt;
begin
if AFreeEntries and FHashTable.FFreeEntries then for i:=0 to FCount-1 do FHashTable.FreePointer(FEntries^[i]);
FCount := 0;
end;
function TGMHashEntryBucket.Obj: TGMHashEntryBucket;
begin
Result := Self;
end;
procedure TGMHashEntryBucket.SetCapacity(const NewCapacity: TBucketIdx);
begin
{TODO: Bessere Fehlermeldung}
//if (NewCapacity < 0) or (NewCapacity > cMaxPtrArraySize) then raise EGMException.ObjError(Format(RStrListCapacityError, [NewCapacity, cMaxPtrArraySize]), Self, 'SetCapacity');
if NewCapacity <> FCapacity then
begin
ReallocMem(FEntries, NewCapacity * SizeOf(Pointer));
FCapacity := NewCapacity;
end;
end;
function TGMHashEntryBucket.InsertIdx(const AKey: IUnknown): TBucketIdx;
const cStrMethodName = 'InsertIdx';
function _InsertIdx(L, R: TBucketIdx): TBucketIdx;
var M: LongInt;
begin
if L >= R then Result := L else
begin
M := (L + R) shr 1;
case FHashTable.CompareEntries(AKey, FHashTable.EntryAsIntf(FEntries^[M])) of
crAEqualToB, crALessThanB: Result := _InsertIdx(L, M);
crAGreaterThanB: if L = M then Result := R else Result := _InsertIdx(M, R);
else
{$IFNDEF STANDALONE_COLLECTIONS}
raise EGMException.ObjError(RStrInvalidCompareResult, Self, cStrMethodName);
{$ELSE}
raise Exception.Create(GMStringJoin(GMStringJoin(GMObjName(Self), cStrErrNameSep, cStrMethodName), ': ', RStrInvalidCompareResult));
{$ENDIF}
end;
end;
end;
begin
Result := _InsertIdx(0, FCount);
end;
function TGMHashEntryBucket.FindIdxOfKey(const AKey: IUnknown; var Idx: TBucketIdx): Boolean;
begin
Idx := InsertIdx(AKey);
Result := GMIsInRange(Idx, 0, FCount-1) and (FHashTable.CompareEntries(FHashTable.EntryAsIntf(FEntries^[Idx]), AKey) = crAEqualToB);
end;
function TGMHashEntryBucket.FindKey(const AKey: IUnknown; out AEntry): Boolean;
var Idx: TBucketIdx;
begin
Result := FindIdxOfKey(AKey, Idx);
if Result then FHashTable.AssignOutEntry(FEntries^[Idx], AEntry);
end;
function TGMHashEntryBucket.AddPointer(const ANewEntry: Pointer): Boolean;
var Idx: LongInt; EntryIntf: IUnknown;
begin
EntryIntf := FHashTable.EntryAsIntf(ANewEntry);
Idx := InsertIdx(EntryIntf);
Result := FHashTable.FAcceptDuplicates or (Idx = FCount) or (FHashTable.CompareEntries(EntryIntf, FHashTable.EntryAsIntf(FEntries^[Idx])) <> crAEqualToB);
if not Result then Exit;
if FCount = FCapacity then SetCapacity(FCapacity + GrowDelta(FCapacity));
if Idx < FCount then System.Move(FEntries^[Idx], FEntries^[Idx + 1], (FCount - Idx) * SizeOf(Pointer));
FEntries^[Idx] := ANewEntry;
Inc(FCount);
end;
procedure TGMHashEntryBucket.RemoveByIdx(const AIdx: LongInt);
begin
//NotifyBeforeRemoveItem(FEntries^[i], i);
if FHashTable.FFreeEntries then FHashTable.FreePointer(FEntries^[AIdx]);
Dec(FCount);
if AIdx < FCount then System.Move(FEntries^[AIdx + 1], FEntries^[AIdx], (FCount - AIdx) * SizeOf(Pointer));
if FCapacity - FCount >= GrowDelta(FCapacity) then SetCapacity(FCapacity - GrowDelta(FCapacity));
end;
function TGMHashEntryBucket.RemoveByKey(const AKey: IUnknown): Boolean;
var idx: TBucketIdx;
begin
Result := FindIdxOfKey(AKey, idx);
if not Result then Exit;
RemoveByIdx(idx);
end;
function TGMHashEntryBucket.RemovePointer(const AInstance: Pointer): Boolean;
var i: LongInt;
begin
for i:=0 to FCount-1 do if FEntries^[i] = AInstance then begin RemoveByIdx(i); Result := True; Exit; end;
Result := False;
end;
{ --------------------------------- }
{ ---- TGMHashBitMaskDirectory ---- }
{ --------------------------------- }
constructor TGMHashBitMaskDirectory.Create(const AHashTable: TGMHashTableBase; const AMaxHashBits: Byte; const AHashBitOffs: Byte; const ARefLifeTime: Boolean);
begin
inherited Create(ARefLifeTime);
FHashTable := AHashTable;
FHashBitOffs := AHashBitOffs;
FMaxHashBits := AMaxHashBits;
end;
function TGMHashBitMaskDirectory.Obj: TGMHashBitMaskDirectory;
begin
Result := Self;
end;
function TGMHashBitMaskDirectory.CalcDirEntryIndex(const AHashCode: TGMHashCode): LongInt;
begin
Result := (AHashCode and FHashBitMask) shr (FHashBitOffs + FMaxHashBits - FHashBitCount);
end;
function TGMHashBitMaskDirectory.FindDirEntry(const AHashCode: TGMHashCode): IUnknown;
begin
if Length(FDirEntries) = 0 then Exit;
Result := FDirEntries[CalcDirEntryIndex(AHashCode)];
end;
procedure TGMHashBitMaskDirectory.ExpandHash(const ADirEntryIdx: LongInt);
var NewSize, i: LongInt; DirEntry: IUnknown;
begin
NewSize := Length(FDirEntries) * 2;
if NewSize = 0 then NewSize := 1;
SetLength(FDirEntries, NewSize);
for i:=NewSize div 2 - 1 downto 0 do
begin
DirEntry := FDirEntries[i];
FDirEntries[i*2] := DirEntry;
FDirEntries[(i*2)+1] := DirEntry;
if DirEntry <> nil then Inc(FAssignedCount); // <- original entries have already been counted!
end;
Inc(FHashBitCount);
FHashBitMask := (FHashBitMask shr 1) or (1 shl (FHashBitOffs + FMaxHashBits - 1));
end;
function TGMHashBitMaskDirectory.FindBucket(const AHashCode: TGMHashCode; var ABucket: IGMHashEntryBucket): Boolean;
var DirEntry: IUnknown; SubDir: IGMHashBitMaskDirectory;
begin
DirEntry := FindDirEntry(AHashCode);
if DirEntry = nil then Result := False else
begin
if GMQueryInterface(DirEntry, IGMHashBitMaskDirectory, SubDir) then
Result := SubDir.Obj.FindBucket(AHashCode, ABucket)
else
Result := GMQueryInterface(DirEntry, IGMHashEntryBucket, ABucket);
end;
end;
procedure TGMHashBitMaskDirectory.ReHashBuketEntries(const ABucket: IGMHashEntryBucket);
var i: LongInt; BucketEntry: Pointer; ReHashCode: TGMHashCode;
begin
for i:=0 to ABucket.Obj.FCount-1 do
begin
BucketEntry := ABucket.Obj.FEntries^[i];
ReHashCode := FHashTable.BuildHashCode(FHashTable.EntryAsIntf(BucketEntry));
{$IFDEF DEBUG}
if not AddPointer(ReHashCode, BucketEntry) then RaiseError(RStrDuplicateHashEntry, Self);
{$ELSE}
AddPointer(ReHashCode, BucketEntry);
{$ENDIF}
end;
ABucket.Obj.Clear(False);
end;
function TGMHashBitMaskDirectory.AddPointer(const AHashCode: TGMHashCode; const ANewEntry: Pointer): Boolean;
var DirEntryIdx, i: LongInt; DirEntry: IUnknown; Bucket: IGMHashEntryBucket; SubDir: IGMHashBitMaskDirectory;
begin
if Length(FDirEntries) = 0 then SetLength(FDirEntries, 1);
DirEntryIdx := CalcDirEntryIndex(AHashCode);
DirEntry := FDirEntries[DirEntryIdx];
if DirEntry = nil then
begin
Bucket := TGMHashEntryBucket.Create(FHashTable, True); // FHashBitCount,
FDirEntries[DirEntryIdx] := Bucket;
Inc(FAssignedCount);
end
else
if GMQueryInterface(DirEntry, IGMHashBitMaskDirectory, SubDir) then
begin Result := SubDir.Obj.AddPointer(AHashCode, ANewEntry); Exit; end // <- Attention: Recursive call and Exit here!
else
GMQueryInterface(DirEntry, IGMHashEntryBucket, Bucket);
if Bucket = nil then Result := False else
begin
if (Bucket.Obj.FCount < cMaxHashBucketSize) or (FHashBitCount + FHashBitOffs >= cMaxHashcodeBits) then
Result := Bucket.Obj.AddPointer(ANewEntry)
else
begin
// The bucket is full, extend hash bit mask or add new directories.
// There may be more duplicates, but if there are duplicates, neighbours are always duplicate!
if (Length(FDirEntries) > 1) and (FDirEntries[DirEntryIdx and $FE] = FDirEntries[DirEntryIdx or 1]) then
begin
// This two neighbours point to the same bucket, set it nil and re-hash to create a new bucket
{TODO: loop only through relevant entries here}
for i:=Low(FDirEntries) to High(FDirEntries) do
if FDirEntries[i] = Bucket then begin FDirEntries[i] := nil; Dec(FAssignedCount); end;
end
else
if FHashBitCount < FMaxHashBits then
begin
FDirEntries[DirEntryIdx] := nil;
Dec(FAssignedCount);
ExpandHash(DirEntryIdx);
end else
FDirEntries[DirEntryIdx] := TGMHashBitMaskDirectory.Create(FHashTable, Max(FMaxHashBits-1, cMinHashBitsPerDirLevel), FHashBitOffs + FHashBitCount, FRefLifeTime);
ReHashBuketEntries(Bucket);
Result := AddPointer(AHashCode, ANewEntry);
end;
end;
end;
function TGMHashBitMaskDirectory.RemoveByKey(const AHashCode: TGMHashCode; const AKey: IUnknown): Boolean;
var dirEntryIdx: TBucketDirIdx; dirEntry: IUnknown; SubDir: IGMHashBitMaskDirectory; Bucket: IGMHashEntryBucket;
begin
Result := False;
if Length(FDirEntries) = 0 then Exit;
dirEntryIdx := CalcDirEntryIndex(AHashCode);
dirEntry := FDirEntries[dirEntryIdx];
if dirEntry <> nil then
begin
if GMQueryInterface(dirEntry, IGMHashBitMaskDirectory, SubDir) then
begin
Result := SubDir.Obj.RemoveByKey(AHashCode, Akey);
if Result and (SubDir.Obj.FAssignedCount = 0) then begin FDirEntries[dirEntryIdx] := nil; Dec(FAssignedCount); end;
end else
if GMQueryInterface(dirEntry, IGMHashEntryBucket, Bucket) then
begin
Result := Bucket.Obj.RemoveByKey(AKey);
{TODO: add case for merging buckets and shrink directory size}
if Result and (Bucket.Obj.FCount = 0) then begin FDirEntries[dirEntryIdx] := nil; Dec(FAssignedCount); end;
end;
end;
end;
function TGMHashBitMaskDirectory.RemovePointer(const AInstance: Pointer): Boolean;
var i: LongInt; subDir: IGMHashBitMaskDirectory; bucket: IGMHashEntryBucket;
begin
Result := False;
for i:=Low(FDirEntries) to High(FDirEntries) do
if FDirEntries[i] <> nil then
begin
if GMQueryInterface(FDirEntries[i], IGMHashBitMaskDirectory, subDir) then
begin
Result := subDir.Obj.RemovePointer(AInstance);
if Result and (subDir.Obj.FAssignedCount = 0) then begin FDirEntries[i] := nil; Dec(FAssignedCount); end;
end else
if GMQueryInterface(FDirEntries[i], IGMHashEntryBucket, bucket) then
begin
Result := bucket.Obj.RemovePointer(AInstance);
{TODO: add case for merging buckets and shrink directory size}
if Result and (bucket.Obj.FCount = 0) then begin FDirEntries[i] := nil; Dec(FAssignedCount); end;
end;
if Result then Break;
end;
end;
function TGMHashBitMaskDirectory.FirstEntry: Pointer;
label SearchDirEntry;
var DirEntryIdx: TBucketDirIdx; SubDir: IGMHashBitMaskDirectory; Bucket: IGMHashEntryBucket;
begin
Result := nil;
DirEntryIdx := Low(FDirEntries);
SearchDirEntry:
while (DirEntryIdx <= High(FDirEntries)) and (FDirEntries[DirEntryIdx] = nil) do Inc(DirEntryIdx);
if DirEntryIdx > High(FDirEntries) then Exit;
if GMQueryInterface(FDirEntries[DirEntryIdx], IGMHashBitMaskDirectory, SubDir) then Result := SubDir.Obj.FirstEntry
else
if GMQueryInterface(FDirEntries[DirEntryIdx], IGMHashEntryBucket, Bucket) then
if Bucket.Obj.FCount > 0 then Result := Bucket.Obj.FEntries[0] else
begin Inc(DirEntryIdx); goto SearchDirEntry; end;
end;
function TGMHashBitMaskDirectory.LastEntry: Pointer;
label SearchDirEntry;
var DirEntryIdx: LongInt; SubDir: IGMHashBitMaskDirectory; Bucket: IGMHashEntryBucket;
begin
Result := nil;
DirEntryIdx := High(FDirEntries);
SearchDirEntry:
while (DirEntryIdx >= Low(FDirEntries)) and (FDirEntries[DirEntryIdx] = nil) do Dec(DirEntryIdx);
if DirEntryIdx < Low(FDirEntries) then Exit;
if GMQueryInterface(FDirEntries[DirEntryIdx], IGMHashBitMaskDirectory, SubDir) then Result := SubDir.Obj.FirstEntry
else
if GMQueryInterface(FDirEntries[DirEntryIdx], IGMHashEntryBucket, Bucket) then
if Bucket.Obj.FCount > 0 then Result := Bucket.Obj.FEntries[Bucket.Obj.FCount-1] else
begin Dec(DirEntryIdx); goto SearchDirEntry; end;
end;
{ -------------------------- }
{ ---- TGMHashTableBase ---- }
{ -------------------------- }
function TGMHashTableBase.CreateIterator(const AReverse, AConcurrentThreadLock: Boolean): IGMIterator;
begin
Result := TGMHashTableIterator.Create(Self, AConcurrentThreadLock, AReverse, True);
end;
function TGMHashTableBase.BuildHashCode(const AKey: IUnknown): TGMHashCode;
var PIHashCode: IGMHashCode;
begin
GMCheckQueryInterface(AKey, IGMHashCode, PIHashCode, 'BuildHashCode');
Result := PIHashCode.HashCode;
end;
procedure TGMHashTableBase.Clear(const ANotify: Boolean);
var OldCount: LongInt;
begin
CriticalSection.EnterCriticalSection;
try
if FRootDirectory = nil then Exit;
FRootDirectory := nil;
OldCount := FCount;
FCount := 0;
if ANotify then NotifyAfterCountChanged(OldCount, 0);
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMHashTableBase.AddPointer(const AHashCode: TGMHashCode; ANewEntry: Pointer): Boolean;
begin
CriticalSection.EnterCriticalSection;
try
if FRootDirectory = nil then FRootDirectory := TGMHashBitMaskDirectory.Create(Self, cMaxHashBitsPerDirLevel, 0, True);
Result := FRootDirectory.Obj.AddPointer(AHashCode, ANewEntry);
if Result then
begin Inc(FCount); NotifyAfterCountChanged(FCount-1, FCount); end
else
if FFreeEntries then FreePointer(ANewEntry);
finally
CriticalSection.LeaveCriticalSection;
end;
end;
procedure TGMHashTableBase.DoAfterRemove;
begin
if FRootDirectory.Obj.FAssignedCount = 0 then FRootDirectory := nil;
Dec(FCount);
NotifyAfterCountChanged(FCount+1, FCount);
end;
function TGMHashTableBase.RemoveByKey(const AKey: IUnknown): Boolean;
begin
CriticalSection.EnterCriticalSection;
try
Result := (FRootDirectory <> nil) and FRootDirectory.Obj.RemoveByKey(BuildHashCode(AKey), AKey);
if Result then DoAfterRemove;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMHashTableBase.RemovePointer(const AInstance: Pointer): Boolean;
begin
CriticalSection.EnterCriticalSection;
try
Result := (FRootDirectory <> nil) and FRootDirectory.Obj.RemovePointer(AInstance);
if Result then DoAfterRemove;
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMHashTableBase.Find(const AKey: IUnknown; out AEntry): Boolean;
var PIBucket: IGMHashEntryBucket;
begin
CriticalSection.EnterCriticalSection;
try
Result := (FRootDirectory <> nil) and FRootDirectory.Obj.FindBucket(BuildHashCode(AKey), PIBucket) and PIBucket.Obj.FindKey(AKey, AEntry);
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMHashTableBase.FindNearest(const AKey: IUnknown; out AEntry): Boolean;
begin
raise Exception.Create(Format(RStrNoNearestInHashFmt, [ClassName]));
end;
function TGMHashTableBase.FirstEntry: Pointer;
begin
CriticalSection.EnterCriticalSection;
try
if FRootDirectory = nil then Result := nil else Result := FRootDirectory.Obj.FirstEntry
finally
CriticalSection.LeaveCriticalSection;
end;
end;
function TGMHashTableBase.LastEntry: Pointer;
begin
CriticalSection.EnterCriticalSection;
try
if FRootDirectory = nil then Result := nil else Result := FRootDirectory.Obj.LastEntry
finally
CriticalSection.LeaveCriticalSection;
end;
end;
{ ------------------------------ }
{ ---- TGMHashTableIterator ---- }
{ ------------------------------ }
// Some Statistics, useful for parameter optimization
//var
// BucketCount: LongInt = 0;
// SingleBucketCount: LongInt = 0;
function TGMHashTableIterator.NextEntry(out AEntry): Boolean;
var StackData: PHashIteratorStackRec; DirEntry: IUnknown; SubDir: IGMHashBitMaskDirectory; //Bucket: IGMHashEntryBucket;
procedure NextIndex(var AIndex: LongInt);
begin
if FReverse then Dec(AIndex) else Inc(AIndex);
end;
function TellBucketEntry: Boolean;
begin
if (FCurrentBucket = nil) or (FCurrentBucketEntryIdx < 0) or (FCurrentBucketEntryIdx >= FCurrentBucket.Obj.FCount) then
Result := False
else
begin
(FCollection as TGMHashTableBase).AssignOutEntry(FCurrentBucket.Obj.FEntries[FCurrentBucketEntryIdx], AEntry);
if (FReverse and (FCurrentBucketEntryIdx > 0)) or (not FReverse and (FCurrentBucketEntryIdx < FCurrentBucket.OBj.FCount-1)) then
NextIndex(FCurrentBucketEntryIdx)
else
begin
FCurrentBucketEntryIdx := -1;
NextIndex(StackData.DirEntryIdx);
with StackData^ do
while (DirEntryIdx >= Low(Directory.Obj.FDirEntries)) and (DirEntryIdx <= High(Directory.Obj.FDirEntries)) and
(Directory.Obj.FDirEntries[DirEntryIdx] = FCurrentBucket) do NextIndex(StackData.DirEntryIdx);
FCurrentBucket := nil;
end;
Result := True;
end;
end;
begin
Result := False;
if Length(FDirStack) = 0 then Exit;
StackData := @FDirStack[High(FDirStack)];
if StackData.Directory = nil then Exit;
if TellBucketEntry then begin Result := True; Exit; end;
with StackData^ do
while (DirEntryIdx >= Low(Directory.Obj.FDirEntries)) and (DirEntryIdx <= High(Directory.Obj.FDirEntries)) and
(Directory.Obj.FDirEntries[DirEntryIdx] = nil) do NextIndex(StackData.DirEntryIdx);
if (StackData.DirEntryIdx < Low(StackData.Directory.Obj.FDirEntries)) or
(StackData.DirEntryIdx > High(StackData.Directory.Obj.FDirEntries)) then
begin
SetLength(FDirStack, Length(FDirStack)-1);
if Length(FDirStack) = 0 then Exit;
NextIndex(FDirStack[High(FDirStack)].DirEntryIdx);
Result := NextEntry(AEntry);
Exit;
end;
DirEntry := StackData.Directory.Obj.FDirEntries[StackData.DirEntryIdx];
if GMQueryInterface(DirEntry, IGMHashEntryBucket, FCurrentBucket) then
begin
//Inc(BucketCount);
//if FCurrentBucket.Obj.FCount = 1 then Inc(SingleBucketCount);
if FReverse then FCurrentBucketEntryIdx := FCurrentBucket.Obj.FCount-1 else FCurrentBucketEntryIdx := 0;
if TellBucketEntry then Result := True else
begin
FCurrentBucket := nil;
NextIndex(StackData.DirEntryIdx);
Result := NextEntry(AEntry);
end;
end else
if GMQueryInterface(DirEntry, IGMHashBitMaskDirectory, SubDir) then
begin
SetLength(FDirStack, Length(FDirStack)+1);
FDirStack[High(FDirStack)].Directory := SubDir;
if FReverse then FDirStack[High(FDirStack)].DirEntryIdx := High(SubDir.Obj.FDirEntries) else FDirStack[High(FDirStack)].DirEntryIdx := 0;
Result := NextEntry(AEntry);
end;
end;
procedure TGMHashTableIterator.Reset;
var RootDir: IGMHashBitMaskDirectory;
begin
if not (FCollection is TGMHashTableBase) or ((FCollection as TGMHashTableBase).FRootDirectory = nil) then SetLength(FDirStack, 0) else
begin
SetLength(FDirStack, 1);
RootDir := (FCollection as TGMHashTableBase).FRootDirectory;
FDirStack[Low(FDirStack)].Directory := RootDir;
if FReverse then FDirStack[Low(FDirStack)].DirEntryIdx := High(RootDir.Obj.FDirEntries) else FDirStack[Low(FDirStack)].DirEntryIdx := 0;
end;
FCurrentBucket := nil;
FCurrentBucketEntryIdx := -1;
end;
{ ------------------------- }
{ ---- TGMObjHashTable ---- }
{ ------------------------- }
constructor TGMObjHashTable.Create(const AFreeEntries,
AAcceptDuplicates: Boolean; const ACompareFunc: TGMIntfCompareFunc;
const ARefLifeTime: Boolean);
begin
inherited Create(AAcceptDuplicates, ACompareFunc, ARefLifeTime);
FFreeEntries := AFreeEntries;
end;
procedure TGMObjHashTable.AssignOutEntry(const AEntryPtr: Pointer; out AEntry);
begin
TObject(AEntry) := AEntryPtr;
end;
procedure TGMObjHashTable.FreePointer(var AEntryPtr: Pointer);
begin
//if AEntryPtr <> nil then TObject(AEntryPtr).Free;
FreeAndNil(TObject(AEntryPtr));
end;
function TGMObjHashTable.EntryAsIntf(const AEntryPtr: Pointer): IUnknown;
begin
Result := GMObjAsIntf(TObject(AEntryPtr));
end;
function TGMObjHashTable.Add(const ANewEntry: TObject; const AReplaceIfExists: Boolean): TObject;
var HashCode: TGMHashCode; UnkEntry: IUnknown;
begin
UnkEntry := GMObjAsIntf(ANewEntry);
HashCode := BuildHashCode(UnkEntry);
UnkEntry := nil; // <- Needed when borlands memory manager is used
if AddPointer(HashCode, ANewEntry) then Result := ANewEntry else Result := nil;
end;
function TGMObjHashTable.RemoveByInstance(const AObj: TObject): Boolean;
begin
Result := RemovePointer(Pointer(AObj));
end;
function TGMObjHashTable.First: TObject;
begin
AssignOutEntry(FirstEntry, Result);
end;
function TGMObjHashTable.Last: TObject;
begin
AssignOutEntry(LastEntry, Result);
end;
{ -------------------------- }
{ ---- TGMIntfHashTable ---- }
{ -------------------------- }
constructor TGMIntfHashTable.Create(const AAcceptDuplicates: Boolean; const ACompareFunc: TGMIntfCompareFunc; const ARefLifeTime: Boolean);
begin
inherited Create(AAcceptDuplicates, ACompareFunc, ARefLifeTime);
FFreeEntries := True;
end;
procedure TGMIntfHashTable.FreePointer(var AEntryPtr: Pointer);
begin
//if AEntryPtr <> nil then
IUnknown(AEntryPtr) := nil;
end;
procedure TGMIntfHashTable.AssignOutEntry(const AEntryPtr: Pointer; out AEntry);
begin
IUnknown(AEntry) := IUnknown(AEntryPtr);
end;
function TGMIntfHashTable.EntryAsIntf(const AEntryPtr: Pointer): IUnknown;
begin
Result := IUnknown(AEntryPtr);
end;
function TGMIntfHashTable.Add(const ANewEntry: IUnknown; const AReplaceIfExists: Boolean): IUnknown;
var ItemHolder: IUnknown;
begin
//
// Always add the real IUnknown representation for proper iterator return values, and put an additional RefCount for the duration of this call
//
if not GMQueryInterface(ANewEntry, IUnknown, ItemHolder) then Exit;
//
// Always _AddRef! Either the entry gets stored or, if it is a duplicate, it will be released again.
//
ItemHolder._AddRef;
if AddPointer(BuildHashCode(ItemHolder), Pointer(ItemHolder)) then Result := ANewEntry;
end;
function TGMIntfHashTable.RemoveByInstance(const AIntf: IUnknown): Boolean;
var unk: IUnknown;
begin
Result := GMQueryInterface(AIntf, IUnknown, unk) and RemovePointer(Pointer(unk)); // <- use real Iunknown representation for proper object identification
end;
function TGMIntfHashTable.First: IUnknown;
begin
AssignOutEntry(FirstEntry, Result);
end;
function TGMIntfHashTable.Last: IUnknown;
begin
AssignOutEntry(LastEntry, Result);
end;
{ ----------------------- }
{ ---- TGMIntegerMap ---- }
{ ----------------------- }
constructor TGMIntegerMap.Create(const ANotifyProc: TNotifyIntMapChangeProc; const ARefLifeTime: Boolean = False);
begin
inherited Create(ARefLifeTime);
FNotifyProc := ANotifyProc;
end;
destructor TGMIntegerMap.Destroy;
begin
SetCapacity(0);
inherited Destroy;
end;
function TGMIntegerMap.Obj: TGMIntegerMap;
begin
Result := Self;
end;
procedure TGMIntegerMap.IntMapChanged(const Value: LongInt);
begin
if Assigned(FNotifyProc) then FNotifyProc(Value);
end;
function TGMIntegerMap.MapIntegerOnInteger(const MapValue: LongInt): LongInt;
begin
Result := Values[MapValue];
end;
function TGMIntegerMap.IsEmpty: Boolean;
begin
Result := Count = 0;
end;
function TGMIntegerMap.GetCount: LongInt;
begin
Result := Count;
end;
function TGMIntegerMap.ExecuteOperation(const Operation: LongInt; const Parameter: IUnknown = nil): Boolean;
begin
Result := True;
case Operation of
{$IFNDEF STANDALONE_COLLECTIONS}
Ord(opClear): Clear(True);
{$ELSE}
0: Clear(True);
{$ENDIF}
else Result := False;
end;
end;
procedure TGMIntegerMap.SetCapacity(const NewCapacity: LongInt);
const cStrMethodName = 'SetCapacity';
begin
{TODO: Bessere Fehlermeldung}
if (NewCapacity < 0) or (NewCapacity > cMaxIntArraySize) then RaiseError(Format(RStrListCapacityError, [NewCapacity, cMaxIntArraySize]), Self, cStrMethodName);
if NewCapacity <> FCapacity then
begin
ReallocMem(FValues, NewCapacity * SizeOf(LongInt));
FCapacity := NewCapacity;
end;
end;
function TGMIntegerMap.GetMappedValue(Index: LongInt): LongInt;
const cStrMethodName = 'GetMappedValue';
begin
GMCheckIntRange(RStrMapIndex, Index, 0, Count-1, Self, cStrMethodName);
Result := FValues^[Index];
end;
function TGMIntegerMap.InsertIdx(const Value: LongInt): LongInt;
function _InsertIdx(L, R: LongInt): LongInt;
var M: LongInt;
begin
if L >= R then Result := L else
begin
M := (L + R) shr 1;
if Value <= FValues^[M] then Result := _InsertIdx(L, M) else
if L = M then Result := R else Result := _InsertIdx(M, R);
end;
end;
begin
{if IsEmpty then Result := 0 else} Result := _InsertIdx(0, Count);
end;
procedure TGMIntegerMap.Add(const Value: LongInt);
const cStrMethodName = 'Add';
var Idx: LongInt;
begin
if Assigned(OnDecideAddValue) and not OnDecideAddValue(Value) then Exit;
Idx := InsertIdx(Value);
if (Idx = Count) or (FValues^[Idx] <> Value) then
begin
GMCheckIntRange(RStrMapIndex, Idx, 0, FCount, Self, cStrMethodName);
if FCount = FCapacity then SetCapacity(FCapacity + GrowDelta(FCapacity));
if Idx < FCount then System.Move(FValues^[Idx], FValues^[Idx + 1], (FCount - Idx) * SizeOf(LongInt));
FValues^[Idx] := Value;
Inc(FCount);
IntMapChanged(Value);
end;
end;
procedure TGMIntegerMap.AddRange(Value1, Value2: LongInt);
var i, Tmp: LongInt;
begin
if Value1 > Value2 then begin Tmp := Value1; Value1 := Value2; Value2 := Tmp; end;
for i:=Value1 to Value2 do Add(i)
end;
procedure TGMIntegerMap.Remove(const Value: LongInt);
const cStrMethodName = 'Remove';
var Idx: LongInt;
begin
Idx := InsertIdx(Value);
if (Idx < Count) and (FValues^[Idx] = Value) then
begin
GMCheckIntRange(RStrMapIndex, Idx, 0, FCount-1, Self, cStrMethodName);
Dec(FCount);
if Idx < FCount then System.Move(FValues^[Idx + 1], FValues^[Idx], (FCount - Idx) * SizeOf(LongInt));
if FCapacity - FCount >= GrowDelta(FCapacity) then SetCapacity(FCapacity - GrowDelta(FCapacity));
IntMapChanged(Value);
end;
end;
procedure TGMIntegerMap.Toggle(const Value: LongInt);
begin
if Contains(Value) then Remove(Value) else Add(Value);
end;
function TGMIntegerMap.Contains(const Value: LongInt): Boolean;
var Idx: LongInt;
begin
Idx := InsertIdx(Value);
Result := (Idx < Count) and (FValues^[Idx] = Value);
end;
procedure TGMIntegerMap.Clear(const Notify: Boolean);
var i: LongInt; ValArr: array of LongInt;
begin
if Notify then
begin
SetLength(ValArr, Count);
for i:=0 to Count-1 do ValArr[i] := Values[i];
end;
SetCapacity(0);
FCount := 0;
if Notify then for i:=Low(ValArr) to High(ValArr) do IntMapChanged(ValArr[i]);
end;
end.