{ +-------------------------------------------------------------+ } { | | } { | GM-Software | } { | =========== | } { | | } { | Project: All Projects | } { | | } { | Description: Collections/Containers, ArrayLists, AVL- | } { | Trees and HashTables with common interfaces. | } { | All Collections are thread safe! | } { | | } { | Copyright (C) - 2011 - Gerrit Moeller. | } { | | } { | Source code dstributed under MIT license. | } { | | } { | See: https://www.gm-software.de | } { | | } { +-------------------------------------------------------------+ } {$INCLUDE GMCompilerSettings.inc} {.$DEFINE STANDALONE_COLLECTIONS} // <- avoid using GMIntf and GMCommon units unit GMCollections; interface uses GMStrDef, {$IFNDEF JEDIAPI}Windows{$ELSE}{$IFNDEF FPC}jwaWinType,{$ENDIF} jwaWinError{$ENDIF} {$IFNDEF STANDALONE_COLLECTIONS}, GMIntf{$ENDIF}; const cMaxPtrArraySize = High(PtrInt) div SizeOf(Pointer); cMaxIntArraySize = High(PtrInt) div SizeOf(PtrInt); cGrowDeltaDiv = 5; // <- 20% cGrowDeltaMax = 1024; { ------------------------------------------------------------------- } { ---- Re-defined types when not using GMIntf and GMCommon units ---- } { ------------------------------------------------------------------- } {$IFDEF STANDALONE_COLLECTIONS} const cInvalidItemIdx = Low(LongInt); // -1; type TGMCompareResult = (crALessThanB, crAEqualToB, crAGreaterThanB); {$IFNDEF FPC} {$IFDEF CPU64} PtrInt = Int64; PtrUInt = QWord; {$ELSE} PtrInt = LongInt; PtrUInt = LongWord; {$ENDIF} PPtrInt = ^PtrInt; PPtrUInt = ^PtrUInt; {$ENDIF} TGMHashCode = PtrInt; IGMCriticalSection = interface(IUnknown) ['{278BDF06-1387-4181-A83D-8DDF4E18CE03}'] procedure EnterCriticalSection; procedure LeaveCriticalSection; //function TryEnterCriticalSection: Boolean; stdcall; end; IGMGetCount = interface(IUnknown) ['{93880081-2684-11d5-AB38-000021DCAD19}'] function GetCount: PtrInt; stdcall; property Count: PtrInt 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: PtrInt; const IID: TGUID; out Intf): HResult; stdcall; end; IGMMapIntegerOnInteger = interface(IUnknown) ['{1BC6F7EB-C230-48ba-B383-B332D555DA6F}'] function MapIntegerOnInteger(const MapValue: PtrInt): PtrInt; stdcall; end; IGMHashCode = interface(IUnknown) ['{9C61B58B-41DF-4695-9716-AC4A343DC2DB}'] function HashCode: TGMHashCode; end; TGMRefCountedObj = 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_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} AIID: TGUID; out AIntf): HResult; virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; function _AddRef: LongInt; virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; function _Release: LongInt; virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; // 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(TGMRefCountedObj, IGMCriticalSection) protected FCriticalSection: TRTLCriticalSection; public constructor Create(const ARefLifeTime: Boolean = True); override; destructor Destroy; override; procedure EnterCriticalSection; procedure LeaveCriticalSection; function TryEnterCriticalSection: Boolean; end; TGMCriticalSectionLock = class(TGMRefCountedObj) 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: PtrInt) 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 AKeyToCompare: IUnknown; out AEntry): Boolean; function FindNearest(const AKeyToCompare: IUnknown; out AEntry): Boolean; function RemoveByKey(const AKeyToCompare: IUnknown): Boolean; function IsValidIndex(const AIndex: PtrInt): Boolean; function CompareEntries(const EntryA, EntryB: IUnknown): TGMCompareResult; property Count: PtrInt 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(TGMRefCountedObj, IGMIterator) protected FCollection: TObject; FReverse: Boolean; //FThreadLock: IUnknown; FThreadLock: RGMCriticalSectionLock; 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(TGMRefCountedObj, IGMCriticalSection, IGMCollection, IGMGetCount, IGMCreateIterator, IGMClear) protected FCount: PtrInt; 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: PtrInt); 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: PtrInt; virtual; stdcall; function IsEmpty: Boolean; virtual; function IsValidIndex(const AIndex: PtrInt): Boolean; virtual; procedure Clear(const ANotify: Boolean = True); virtual; abstract; function Find(const AKeyToCompare: IUnknown; out AEntry): Boolean; virtual; abstract; function FindNearest(const AKeyToCompare: IUnknown; out AEntry): Boolean; virtual; abstract; function RemoveByKey(const AKeyToCompare: IUnknown): Boolean; virtual; abstract; function CreateIterator(const AReverse: Boolean = False; const AConcurrentThreadLock: Boolean = False): IGMIterator; virtual; abstract; property Count: PtrInt read GetCount; property CompareItemFunc: TGMIntfCompareFunc read FCompareFunc write SetCompareFunc; property CriticalSection: IGMCriticalSection read FCriticalSection implements IGMCriticalSection; property OnAfterCountChanged: TGMCountChangedProc read FOnAfterCountChanged write SetOnAfterCountChanged; end; { --------------------------- } { ---- Array Collections ---- } { --------------------------- } // // NOTE: Indexing of all array implementations is zero based! // PPointerArray = ^TPointerArray; TPointerArray = array[0 .. cMaxPtrArraySize-1] of Pointer; TGMArrayCollectionBase = class(TGMCollectionBase, IGMGetIntfByPosition, IGMLoadStoreData) protected FEntries: PPointerArray; FCapacity: PtrInt; FSorted: Boolean; FFreeEntries: Boolean; function GetSorted: Boolean; procedure SetSorted(const AValue: Boolean); procedure SetCapacity(const ANewCapacity: PtrInt); function IndexOfPointer(const Ptr: Pointer): PtrInt; function IsDuplicate(const AKeyToCompare: IUnknown; var AIndex: PtrInt): Boolean; procedure InsertPointer(const AInstance: Pointer; const AIndex: PtrInt); function EntryAsIntf(const Index: PtrInt): IUnknown; virtual; abstract; procedure FreePointer(var Item: Pointer); virtual; abstract; procedure AfterCompareFuncChanged; override; procedure NotifyAfterAddItem(const AItem: Pointer; const AIndex: PtrInt); virtual; abstract; procedure NotifyBeforeRemoveItem(const AItem: Pointer; const AIndex: PtrInt); virtual; abstract; procedure CheckSorted(const AOperationName: TGMString); procedure CheckUnsorted(const AOperationName: TGMString); public constructor Create(const AAcceptDuplicates: Boolean = True; const ASorted: Boolean = False; const ACompareFunc: TGMIntfCompareFunc = nil; const ARefLifeTime: Boolean = False); reintroduce; function GetIntfByPosition(const APosition: PtrInt; const AIID: TGUID; out AIntf): HResult; virtual; stdcall; procedure Clear(const ANotify: Boolean = True); override; procedure Sort; virtual; //procedure Pack; virtual; {$IFDEF STANDALONE_COLLECTIONS} procedure LoadData(const Source: IUnknown; const ACryptCtrlData: PGMCryptCtrlData = nil); stdcall; procedure StoreData(const Dest: IUnknown; const ACryptCtrlData: PGMCryptCtrlData = nil); stdcall; {$ELSE} procedure LoadData(const Source: IGMValueStorage; const ACryptCtrlData: PGMCryptCtrlData = nil); stdcall; procedure StoreData(const Dest: IGMValueStorage; const ACryptCtrlData: PGMCryptCtrlData = nil); stdcall; {$ENDIF} procedure RemoveByIdx(const AIndex: PtrInt; ADelCount: PtrInt = 1); virtual; function RemoveByKey(const AKeyToCompare: IUnknown): Boolean; override; function CalcInsertIdx(const AKeyToCompare: IUnknown): PtrInt; virtual; function IndexOf(const AKeyToCompare: IUnknown): PtrInt; virtual; function IndexOfNearest(const AKeyToCompare: IUnknown): PtrInt; virtual; function Find(const AKeyToCompare: IUnknown; out AEntry): Boolean; override; function FindNearest(const AKeyToCompare: IUnknown; out AEntry): Boolean; override; procedure Rotate(ADelta: PtrInt; const AStartIdx: PtrInt = 0); procedure Exchange(const AIndex1, AIndex2: PtrInt); //procedure Move(const ASourceIdx, ADestIdx: PtrInt); procedure Reverse; property Capacity: PtrInt read FCapacity {write SetCapacity}; property Sorted: Boolean read GetSorted write SetSorted; end; TGMArrayCollectionIteratorBase = class(TGMIteratorBase) protected FCurrentIdx: PtrInt; 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: PtrInt) of object; IGMObjArrayCollection = interface(IGMObjCollection) ['{E83BD4DC-E50E-4fc3-9161-9F5829BC6C92}'] function GetItem(const Index: PtrInt): TObject; procedure SetItem(const Index: PtrInt; 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): PtrInt; function Insert(const AObj: TObject; const AIndex: PtrInt; const AReplaceIfExists: Boolean = False): TObject; //function First: TObject; //function Last: TObject; function IndexOfObj(const AObj: TObject): PtrInt; //function FindObj(const AObj: TObject; var Index: LongInt): Boolean; property Items[const Index: PtrInt]: 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: PtrInt; DelCount: PtrInt = 1); procedure Rotate(Delta: PtrInt; const StartPos: PtrInt = 0); procedure Exchange(const Index1, Index2: PtrInt); procedure Reverse; procedure Sort; function IndexOf(const AKeyToCompare: IUnknown): PtrInt; function IndexOfNearest(const AKeyToCompare: IUnknown): PtrInt; property Sorted: Boolean read GetSorted write SetSorted; end; TGMObjArrayCollection = class(TGMArrayCollectionBase, IGMObjArrayCollection, IGMObjCollection) protected function ObjInsertIdx(const AObj: TObject): PtrInt; function InternalInsert(const AObj: TObject; var AIndex: PtrInt; const AReplaceIfExists: Boolean = False): Boolean; virtual; function GetItem(const AIndex: PtrInt): TObject; virtual; function EntryAsIntf(const AIndex: PtrInt): IUnknown; override; procedure SetItem(const AIndex: PtrInt; const AValue: TObject); virtual; procedure FreePointer(var AItem: Pointer); override; procedure SetOnAfterAddItem(const AValue: TGMObjItemAddRemoveProc); procedure SetOnBeforeRemoveItem(const Value: TGMObjItemAddRemoveProc); procedure NotifyAfterAddItem(const AItem: Pointer; const AIndex: PtrInt); override; procedure NotifyBeforeRemoveItem(const AItem: Pointer; const AIndex: PtrInt); 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): PtrInt; virtual; function Insert(const AObj: TObject; const AIndex: PtrInt; const AReplaceIfExists: Boolean = False): TObject; virtual; function First: TObject; virtual; function Last: TObject; virtual; function IndexOfObj(const AObj: TObject): PtrInt; function RemoveByInstance(const AObj: TObject): Boolean; //function FindObj(const AObj: TObject; var Index: LongInt): Boolean; virtual; property Entries[const Index: PtrInt]: TObject read GetItem write SetItem; default; // <- Indexing is zero based! property FreeEntries: Boolean read FFreeEntries write FFreeEntries; end; TGMObjectCollectionIterator = class(TGMArrayCollectionIteratorBase) protected procedure AssignOutEntry(out AEntry); override; end; TGMIntfItemAddRemoveProc = procedure(const Sender: TObject; const Item: IUnknown; const AIndex: LongInt) of object; IGMIntfArrayCollection = interface(IGMIntfCollection) ['{E83BD4DC-E50E-4fc3-9161-9F5829BC6C92}'] function GetItem(const Index: PtrInt): 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): PtrInt; function Insert(const AIntf: IUnknown; const AIndex: PtrInt; const AReplaceIfExists: Boolean = False): IUnknown; //function Remove(const AIntf: IUnknown): LongInt; //function First: IUnknown; //function Last: IUnknown; function IndexOfObj(const AIntf: IUnknown): PtrInt; //function FindObj(const AIntf: IUnknown; var Index: LongInt): Boolean; property Items[const Index: PtrInt]: 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: PtrInt; DelCount: PtrInt = 1); procedure Rotate(Delta: PtrInt; const StartPos: PtrInt = 0); procedure Exchange(const Index1, Index2: PtrInt); procedure Reverse; procedure Sort; function IndexOf(const AKeyToCompare: IUnknown): PtrInt; function IndexOfNearest(const AKeyToCompare: IUnknown): PtrInt; property Sorted: Boolean read GetSorted write SetSorted; end; TGMIntfArrayCollection = class(TGMArrayCollectionBase, IGMIntfCollection, IGMIntfArrayCollection) protected function InternalInsert(const AIntf: IUnknown; var AIndex: PtrInt; const AReplaceIfExists: Boolean = False): Boolean; virtual; function GetItem(const Index: PtrInt): IUnknown; virtual; function EntryAsIntf(const AIndex: PtrInt): IUnknown; override; procedure FreePointer(var AItem: Pointer); override; procedure SetOnAfterAddItem(const AValue: TGMIntfItemAddRemoveProc); procedure SetOnBeforeRemoveItem(const Value: TGMIntfItemAddRemoveProc); procedure NotifyAfterAddItem(const AItem: Pointer; const AIndex: PtrInt); override; procedure NotifyBeforeRemoveItem(const AItem: Pointer; const AIndex: PtrInt); 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): PtrInt; virtual; function Insert(const AIntf: IUnknown; const AIndex: PtrInt; const AReplaceIfExists: Boolean = False): IUnknown; virtual; function Find(const AKeyToCompare: IUnknown; out AEntry): Boolean; override; function FindNearest(const AKeyToCompare: IUnknown; out AEntry): Boolean; override; function First: IUnknown; virtual; function Last: IUnknown; virtual; function IndexOfObj(const AIntf: IUnknown): PtrInt; function RemoveByInstance(const AIntf: IUnknown): Boolean; //function FindObj(const Intf: IUnknown; var Index: LongInt): Boolean; virtual; property Entries[const Index: PtrInt]: IUnknown read GetItem; default; // <- Indexing is zero based! end; TGMIntfArrayCollectionIterator = class(TGMArrayCollectionIteratorBase) 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 Index: 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 AKeyToCompare: IUnknown): TGMAvlTreeNodeBase; procedure SetCompareFunc(const AValue: TGMIntfCompareFunc); override; function AddNode(const ANode: TGMAvlTreeNodeBase; const AReplaceIfExists: Boolean): Boolean; function FindNode(const AKeyToCompare: IUnknown): TGMAvlTreeNodeBase; function FindNearestNode(const AKeyToCompare: 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 AKeyToCompare: 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 AKeyToCompare: IUnknown; out AEntry): Boolean; override; function FindNearest(const AKeyToCompare: 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 AKeyToCompare: IUnknown; out AEntry): Boolean; override; function FindNearest(const AKeyToCompare: 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 TBucketDirIdx 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(TGMRefCountedObj, IGMHashEntryBucket) protected FEntries: PPointerArray; FCount: TBucketIdx; FCapacity: TBucketIdx; FHashTable: TGMHashTableBase; //FHashBitCount: Byte; function CalcInsertIdx(const AKeyToCompare: IUnknown): TBucketIdx; procedure SetCapacity(const NewCapacity: TBucketIdx); function FindIdxOfKey(const AKeyToCompare: IUnknown; var AIndex: 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 AKeyToCompare: IUnknown; out AEntry): Boolean; function AddPointer(const ANewEntry: Pointer): Boolean; procedure RemoveByIdx(const AIdx: LongInt); function RemoveByKey(const AKeyToCompare: 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(TGMRefCountedObj, IGMHashBitMaskDirectory) protected FHashBitCount: SmallInt; FHashBitOffs: SmallInt; FMaxHashBits: SmallInt; 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): PtrInt; 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 AKeyToCompare: 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 AKeyToCompare: 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 AKeyToCompare: IUnknown; out AEntry): Boolean; override; function FindNearest(const AKeyToCompare: IUnknown; out AEntry): Boolean; override; function RemoveByKey(const AKeyToCompare: 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; { ----------------------------- } { ---- Generic Collections ---- } { ----------------------------- } {$IFDEF HAS_GENERICS} TGMGenericFinalizeEntryProc<T> = procedure (const Entry: T); TGMGenericCompareFunc<T> = function (const EntryA, EntryB: T): TGMCompareResult; TGMGenericEntryAddRemoveProc<T> = procedure(const Sender: TObject; const Entry: T; const Index: PtrInt) of object; IGMGenericIterator<T> = interface(IUnknown) ['{031CB54D-9BD7-4BA8-A847-A309B4FFD49C}'] function NextEntry(var AEntry: T): Boolean; procedure Reset; end; IGMCreateGenericIterator<T> = interface(IGMGetCount) ['{E57F2FDF-8660-448E-968D-C7248A20EA24}'] function CreateIterator(const AReverse: Boolean = False; const AConcurrentThreadLock: Boolean = False): IGMGenericIterator<T>; end; IGMGenericCollection<T> = interface(IGMCreateGenericIterator<T>) ['{468D1111-7D28-4195-9C44-13065516B0F4}'] function IsEmpty: Boolean; function Add(const ANewEntry: T; const AReplaceIfExists: Boolean = False): T; function Contains(const AEntryToFind: T): Boolean; function Find(const AEntryToFind: T; var AFoundEntry: T): Boolean; function FindNearest(const AEntryToFind: T; var AEntry: T): Boolean; procedure Clear(const ANotify: Boolean = True); function RemoveByKey(const AKeyToCompare: T): Boolean; //function RemoveByInstance(const AInstance: T): Boolean; function CompareEntries(const AEntryA, AEntryB: T): TGMCompareResult; function IsValidIndex(const AIndex: PtrInt): Boolean; function First: T; function Last: T; procedure SetCompareFunc(const Value: TGMGenericCompareFunc<T>); procedure SetOnAfterCountChanged(const Value: TGMCountChangedProc); procedure SetOnAfterAddItem(const Value: TGMGenericEntryAddRemoveProc<T>); procedure SetOnBeforeRemoveItem(const Value: TGMGenericEntryAddRemoveProc<T>); property Count: PtrInt read GetCount; property CompareItemFunc: TGMGenericCompareFunc<T> write SetCompareFunc; property OnAfterCountChanged: TGMCountChangedProc write SetOnAfterCountChanged; property OnAfterAddItem: TGMGenericEntryAddRemoveProc<T> write SetOnAfterAddItem; property OnBeforeRemoveItem: TGMGenericEntryAddRemoveProc<T> write SetOnBeforeRemoveItem; end; TGMGenericIteratorBase<T> = class(TGMRefCountedObj, IGMGenericIterator<T>) protected FCollectionHolder: IUnknown; FReverse: Boolean; //FThreadLock: IUnknown; FThreadLock: RGMCriticalSectionLock; public constructor Create(const ACollection: IUnknown; const AReverse: Boolean = False; const AConcurrentThreadLock: Boolean = False; const ARefLifeTime: Boolean = True); reintroduce; function NextEntry(var AEntry: T): Boolean; virtual; abstract; procedure Reset; virtual; abstract; end; TGMPlainGenericCollection = class(TGMRefCountedObj) // // Class for global symbol access, the compiler doesn't allow to accesse them in generic classes derived from this class ... // public procedure CheckSorted(const ASortedReqired, ASorted: Boolean; const AOperationName: TGMString); function ArrayGrowDelta(const ACurrentCapacity: PtrInt): PtrInt; function MsgStrArrayIndex: TGMString; end; TGMGenericCollectionBase<T> = class(TGMPlainGenericCollection, IGMCriticalSection, IGMClear) protected FCount: PtrInt; //FContainsManagedType: Boolean; FCompareFunc: TGMGenericCompareFunc<T>; FFinalizeEntryProc: TGMGenericFinalizeEntryProc<T>; FCriticalSection: IGMCriticalSection; FAcceptDuplicates: Boolean; FOnAfterCountChanged: TGMCountChangedProc; FOnAfterAddItem: TGMGenericEntryAddRemoveProc<T>; FOnBeforeRemoveItem: TGMGenericEntryAddRemoveProc<T>; procedure NotifyAfterAddItem(const AEntry: T; const AIndex: PtrInt); procedure NotifyBeforeRemoveItem(const AEntry: T; const AIndex: PtrInt); procedure NotifyAfterCountChanged(const AOldCount, ANewCount: PtrInt); public constructor Create(const AAcceptDuplicates: Boolean = True; const ACompareFunc: TGMGenericCompareFunc<T> = nil; const AFinalizeEntryProc: TGMGenericFinalizeEntryProc<T> = nil; const ARefLifeTime: Boolean = True); reintroduce; overload; destructor Destroy; override; procedure Clear(const ANotify: Boolean = False); virtual; abstract; function GetCount: PtrInt; stdcall; procedure SetCompareFunc(const ACompareFunc: TGMGenericCompareFunc<T>); virtual; function IsEmpty: Boolean; virtual; function NullEntry: T; virtual; function CompareEntries(const AEntryA, AEntryB: T): TGMCompareResult; function IsValidIndex(const AIndex: PtrInt): Boolean; procedure SetOnAfterCountChanged(const AValue: TGMCountChangedProc); procedure SetOnAfterAddItem(const AValue: TGMGenericEntryAddRemoveProc<T>); procedure SetOnBeforeRemoveItem(const AValue: TGMGenericEntryAddRemoveProc<T>); property Count: PtrInt read GetCount; property CompareItemFunc: TGMGenericCompareFunc<T> read FCompareFunc write SetCompareFunc; property CriticalSection: IGMCriticalSection read FCriticalSection implements IGMCriticalSection; property OnAfterCountChanged: TGMCountChangedProc read FOnAfterCountChanged write SetOnAfterCountChanged; end; IGMGenericArrayCollection<T> = interface(IGMGenericCollection<T>) ['{448C6101-CC35-49F6-8811-27EEB8F4CC92}'] function GetSorted: Boolean; procedure SetSorted(const AValue: Boolean); procedure Sort; function GetEntry(const AIndex: PtrInt): T; procedure SetEntry(const AIndex: PtrInt; const AValue: T); function IndexOf(const AKeyToCompare: T): PtrInt; function AddIdx(const ANewEntry: T; const AReplaceIfExists: Boolean = False): PtrInt; function Insert(const ANewEntry: T; const AIndex: PtrInt; const AReplaceIfExists: Boolean = False): T; procedure RemoveByIdx(const AIndex: PtrInt; ADelCount: PtrInt = 1); procedure Rotate(ADelta: PtrInt; const AStartIdx: PtrInt = 0); procedure Exchange(const AIndex1, AIndex2: PtrInt); //procedure Move(const ASourceIdx, ADestIdx: PtrInt); procedure Reverse; property Sorted: Boolean read GetSorted write SetSorted; property Entries[AIndex: PtrInt]: T read GetEntry write SetEntry; default; end; TGMGenericArrayCollection<T> = class(TGMGenericCollectionBase<T>, IGMGenericCollection<T>, IGMGenericArrayCollection<T>) protected FEntries: array of T; FCapacity: PtrInt; FSorted: Boolean; function GetSorted: Boolean; procedure SetSorted(const AValue: Boolean); function GetEntry(const AIndex: PtrInt): T; procedure SetEntry(const AIndex: PtrInt; const AValue: T); procedure SetCapacity(ANewCapacity: PtrInt); procedure InternalInsertEntry(const AEntry: T; const AIndex: PtrInt); function CalcInsertIdx(const AEntry: T): PtrInt; function InternalInsert(const AEntry: T; var AIndex: PtrInt; const AReplaceIfExists: Boolean = False): Boolean; procedure QuickSort(L, R: PtrInt); public constructor Create(const AAcceptDuplicates: Boolean = True; const ASorted: Boolean = False; const ACompareFunc: TGMGenericCompareFunc<T> = nil; const AFinalizeEntryProc: TGMGenericFinalizeEntryProc<T> = nil; const ARefLifeTime: Boolean = True); reintroduce; overload; function CreateIterator(const AReverse: Boolean = False; const AConcurrentThreadLock: Boolean = False): IGMGenericIterator<T>; procedure SetCompareFunc(const ACompareFunc: TGMGenericCompareFunc<T>); override; function IndexOfNearest(const AEntryToFind: T): PtrInt; function IsDuplicate(const AEntry: T; var AIndex: PtrInt): Boolean; function IndexOf(const AEntryToFind: T): PtrInt; function Contains(const AEntryToFind: T): Boolean; function Find(const AEntryToFind: T; var AFoundEntry: T): Boolean; function FindNearest(const AEntryToFind: T; var AEntry: T): Boolean; function Add(const ANewEntry: T; const AReplaceIfExists: Boolean = False): T; function AddIdx(const ANewEntry: T; const AReplaceIfExists: Boolean = False): PtrInt; function Insert(const ANewEntry: T; const AIndex: PtrInt; const AReplaceIfExists: Boolean = False): T; procedure RemoveByIdx(const AIndex: PtrInt; ADelCount: PtrInt = 1); function RemoveByKey(const AKeyToCompare: T): Boolean; procedure Clear(const ANotify: Boolean = False); override; function First: T; function Last: T; procedure Rotate(ADelta: PtrInt; const AStartIdx: PtrInt = 0); procedure Exchange(const AIndex1, AIndex2: PtrInt); //procedure Move(const ASourceIdx, ADestIdx: PtrInt); procedure Reverse; procedure Sort; property Entries[AIndex: PtrInt]: T read GetEntry write SetEntry; default; property Capacity: PtrInt read FCapacity {write SetCapacity}; property Sorted: Boolean read FSorted write SetSorted; end; TGMGenericArrayIterator<T> = class(TGMGenericIteratorBase<T>) protected FCollection: IGMGenericArrayCollection<T>; FCurrentIdx: PtrInt; public constructor Create(const ACollection: IGMGenericArrayCollection<T>; const AReverse: Boolean = False; const AConcurrentThreadLock: Boolean = False; const ARefLifeTime: Boolean = True); reintroduce; function NextEntry(var AEntry: T): Boolean; override; procedure Reset; override; end; RGMGenericKeyAndValue<TK, TV> = record Key: TK; Value: TV; end; IGMGenericMap<TK, TV> = interface(IGMCreateGenericIterator<TV>) // RGMGenericKeyAndValue<TK, TV> ['{07AD200B-F250-4E98-B79A-1F533EE084D1}'] function IsEmpty: Boolean; function Add(const AKey: TK; const AValue: TV; const AReplaceIfExists: Boolean = False): TV; function Find(const AKey: TK; var AFoundEntry: TV): Boolean; function FindNearest(const AKeyToCompare: TK; var AFoundEntry: TV): Boolean; procedure Clear(const ANotify: Boolean = True); function Remove(const AKeyToCompare: TK): Boolean; function CompareEntries(const AEntryA, AEntryB: TK): TGMCompareResult; function IsValidIndex(const AIndex: PtrInt): Boolean; function First: TV; function Last: TV; procedure SetCompareFunc(const Value: TGMGenericCompareFunc<TK>); procedure SetOnAfterCountChanged(const Value: TGMCountChangedProc); //procedure SetOnAfterAddItem(const Value: TGMGenericEntryAddRemoveProc<T>); //procedure SetOnBeforeRemoveItem(const Value: TGMGenericEntryAddRemoveProc<T>); property Count: PtrInt read GetCount; property CompareItemFunc: TGMGenericCompareFunc<TK> write SetCompareFunc; property OnAfterCountChanged: TGMCountChangedProc write SetOnAfterCountChanged; //property OnAfterAddItem: TGMGenericEntryAddRemoveProc<T> write SetOnAfterAddItem; //property OnBeforeRemoveItem: TGMGenericEntryAddRemoveProc<T> write SetOnBeforeRemoveItem; end; function GMGenericCompareUsingOperators<T>(const AValueA, AValueB: T): TGMCompareResult; {$ENDIF} { --------------------- } { ---- Integer Map ---- } { --------------------- } type TGMIntegerMap = class; IGMIntegerMap = interface(IUnknown) ['{59388B7E-4264-4128-992D-CCE1BD926721}'] function Obj: TGMIntegerMap; end; PPtrIntArray = ^TPtrIntArray; TPtrIntArray = array [0 .. cMaxIntArraySize-1] of PtrInt; TNotifyIntMapChangeProc = procedure (const Value: PtrInt) of Object; TIndexDecideFunc = function (const Value: PtrInt): Boolean of Object; TGMIntegerMap = class(TGMRefCountedObj, IGMIntegerMap, IGMMapIntegerOnInteger, IGMGetCount, IGMClear) protected FValues: PPtrIntArray; FCount: PtrInt; FCapacity: PtrInt; FChangeNotifyProc: TNotifyIntMapChangeProc; procedure SetCapacity(const ANewCapacity: PtrInt); function GetMappedValue(AIndex: PtrInt): PtrInt; function CalcInsertIdx(const AValue: PtrInt): PtrInt; function GetCount: PtrInt; stdcall; function MapIntegerOnInteger(const AMapKeyValue: PtrInt): PtrInt; virtual; stdcall; procedure IntMapChanged(const AValue: PtrInt); public OnDecideAddValue: TIndexDecideFunc; constructor Create(const ANotifyProc: TNotifyIntMapChangeProc; const ARefLifeTime: Boolean = False); reintroduce; overload; virtual; destructor Destroy; override; function Obj: TGMIntegerMap; procedure Add(const AValue: PtrInt); procedure RemoveByIdx(const AIndex: PtrInt); procedure Remove(const AValue: PtrInt); procedure Toggle(const AValue: PtrInt); procedure Clear(const ANotify: Boolean = True); virtual; procedure AddRange(AValue1, AValue2: PtrInt); procedure SetRange(AValue1, AValue2: PtrInt); function Contains(const AValue: PtrInt): Boolean; function IsEmpty: Boolean; property Values[Index: PtrInt]: PtrInt read GetMappedValue; default; property Count: PtrInt read FCount; end; // // Collection Helpers // function GMCollectionContains(const ACollection, AKeyToCompare: IUnknown): Boolean; function GMCollectionAddAll(const ASrcCollection, ADstCollection: IUnknown; const AClearDstCollection: Boolean = False): PtrInt; function GMCollectionRemoveAll(const AToRemoveCollection, ARemoveFromCollection: IUnknown): PtrInt; // // Helpers when not using GMCommon and GMIntf units // {$IFDEF STANDALONE_COLLECTIONS} function GMStringJoin(const Value, Separator, Append: TGMString): TGMString; 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: TGMString); function GMHrSucceeded(const AErrorCode: HResult): Boolean; function GMSysErrorMsg(const ErrorCode: LongInt; const Params: array of PGMChar): TGMString; function GMObjAsIntf(const Obj: TObject): IUnknown; procedure GMCheckIntRange(const ValueName: TGMString; const Value, MinValue, MaxValue: LongInt; const Obj: TObject; const CallingName: TGMString); function Min(A, B: LongInt): LongInt; function Max(A, B: LongInt): LongInt; {$ENDIF} implementation uses SysUtils {$IFNDEF STANDALONE_COLLECTIONS}, GMCommon{$ENDIF}; // {$IFDEF HAS_GENERICS}, RTTI{$ENDIF} <- IsManaged(T) function //const // // CStrErrNameSep = ' - '; resourcestring RStrCollectionNotSortedFmt = 'Operation "%s" not supported on unsorted collections'; RStrCollectionSortedFmt = 'Operation "%s" not supported on sorted collections'; RStrArrayIndex = 'Array Index'; RStrListCapacityError = 'List capacity (%d) must be smaller than (%d)'; //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} const cStrCheckSorted = 'CheckSorted'; cStrCheckUnsorted = 'CheckUnsorted'; { ------------------------------------------------------------------ } { ---- Routines needed when not using GMIntf and GMCommon units ---- } { ------------------------------------------------------------------ } {$IFDEF STANDALONE_COLLECTIONS} function GMStringJoin(const Value, Separator, Append: TGMString): TGMString; 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 PGMChar): TGMString; var ApiCode: DWORD; PParams: Pointer; function BuildSysErrMsg(Flags: DWORD): TGMString; var buffer: PGMChar; Len: DWORD; begin Len := FormatMessage(Flags or FORMAT_MESSAGE_ALLOCATE_BUFFER, nil, DWORD(ErrorCode), 0, PGMChar(@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): TGMString; begin Result := ''; end; function GMObjName(const AObj: TObject): TGMString; begin if AObj <> nil then Result := AObj.ClassName else Result := ''; end; procedure GMCheckQueryInterface(const Obj: IUnknown; const IID: TGUID; out Intf; const CallingName: TGMString); var CallerName: TGMString; Hr: HResult; //function LocalBuildCallingName: TGMString; //begin // if CallerName = '' then CallerName := GMStringJoin(BuildCallingName(CallingName, {$I %CurrentRoutine%}), ' - ', // GMFormat('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, {$I %CurrentRoutine%})); 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 GMCompareByInstance(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: TGMString; const Value, MinValue, MaxValue: LongInt; const Obj: TObject; const CallingName: TGMString); begin if not GMIsInRange(Value, MinValue, MaxValue) then raise Exception.Create(GMStringJoin(GMStringJoin(GMObjName(Obj), cStrErrNameSep, CallingName), ': ', GMFormat(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: PtrInt): PtrInt; begin Result := GMBoundedInt(ACurrentCapacity div cGrowDeltaDiv, 1, cGrowDeltaMax); end; function GMCollectionContains(const ACollection, AKeyToCompare: IUnknown): Boolean; var PICollection: IGMCollection; Entry: IUnknown; begin if not GMQueryInterface(ACollection, IGMCollection, PICollection) then Result := False else Result := PICollection.Find(AKeyToCompare, Entry); end; function GMCollectionAddAll(const ASrcCollection, ADstCollection: IUnknown; const AClearDstCollection: Boolean = False): PtrInt; 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 if AClearDstCollection then IntfDst.Clear; 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 if AClearDstCollection then ObjDst.Clear; it := ObjSrc.CreateIterator; while it.NextEntry(ObjEntry) do begin ObjDst.Add(ObjEntry); Inc(Result); end; end; end; function GMCollectionRemoveAll(const AToRemoveCollection, ARemoveFromCollection: IUnknown): PtrInt; var toRemove, removeFrom: IGMIntfCollection; it: IGMIterator; unkEntry: IUnknown; begin Result := 0; if GMQueryInterface(AToRemoveCollection, IGMIntfCollection, toRemove) and GMQueryInterface(ARemoveFromCollection, IGMIntfCollection, removeFrom) then begin it := toRemove.CreateIterator; while it.NextEntry(unkEntry) do begin removeFrom.RemoveByKey(unkEntry); Inc(Result); end; end; end; procedure RaiseError(const AMsg: TGMString; const ACaller: TObject = nil; const ACallingName: TGMString = ''); begin {$IFNDEF STANDALONE_COLLECTIONS} raise EGMException.ObjError(AMsg, ACaller, ACallingName); {$ELSE} raise Exception.Create(GMStringJoin(GMStringJoin(GMObjName(ACaller), cStrErrNameSep, ACallingName), ': ', AMsg)); {$ENDIF} end; { -------------------------- } { ---- TGMRefCountedObj ---- } { -------------------------- } {$IFDEF STANDALONE_COLLECTIONS} constructor TGMRefCountedObj.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 TGMRefCountedObj.AfterConstruction; begin Dec(FRefCount); inherited AfterConstruction; end; procedure TGMRefCountedObj.BeforeDestruction; begin inherited BeforeDestruction; Inc(FRefCount); end; //destructor TGMRefCountedObj.Destroy; //begin //inherited Destroy; //if Assigned(vfGMCheckRefCountOnDestroy) then vfGMCheckRefCountOnDestroy(RefCount-1, Self); //end; procedure TGMRefCountedObj.OnFinalRelease; begin Free; end; //function TGMRefCountedObj.CreateCopyQI(const IID: TGUID; out Intf): HResult; //var PIUnknown: IUnknown; PIAssign: IGMAssignFromObj; //begin //PIUnknown := TGMRefCountedObjClass(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 TGMRefCountedObj.GetClassName: PChar; //var RetVal: TGMString; //begin //RetVal := ClassName; //Result := PChar(RetVal); //end; // //function TGMRefCountedObj.GetClassType: TClass; //begin //Result := ClassType; //end; // //function TGMRefCountedObj.GetInstance: TObject; //begin //Result := Self; //end; // //function TGMRefCountedObj.GetTypeInfo: PTypeInfo; //begin //Result := ClassInfo; //end; function TGMRefCountedObj.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 TGMRefCountedObj._AddRef: LongInt; begin Result := InterlockedIncrement(FRefCount); end; function TGMRefCountedObj._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); begin inherited Create(ARefLifeTime); if ACriticalSection = nil then Exit; // <- allow nil! // force ACriticalSection to support IGMCriticalSection interface GMCheckQueryInterface(ACriticalSection, IGMCriticalSection, FCriticalSection, {$I %CurrentRoutine%}); 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: PtrInt; 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: PtrInt); 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 := GMCompareByInstance(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: PtrInt): Boolean; begin Result := (AIndex >= 0) and (AIndex < FCount); // 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 FThreadLock := TGMCriticalSectionLock.Create(GMObjAsIntf(ACollection)); if AConcurrentThreadLock then FThreadLock.Lock(ACollection); Reset; end; { -------------------------------- } { ---- TGMArrayCollectionBase ---- } { -------------------------------- } Constructor TGMArrayCollectionBase.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 TGMArrayCollectionBase.GetSorted: Boolean; begin Result := FSorted; end; procedure TGMArrayCollectionBase.CheckSorted(const AOperationName: TGMString); begin if not FSorted then RaiseError(GMFormat(RStrCollectionNotSortedFmt, [AOperationName]), Self, cStrCheckSorted); end; procedure TGMArrayCollectionBase.CheckUnsorted(const AOperationName: TGMString); begin if FSorted then RaiseError(GMFormat(RStrCollectionSortedFmt, [AOperationName]), Self, cStrCheckUnsorted); end; function TGMArrayCollectionBase.GetIntfByPosition(const APosition: PtrInt; const AIID: TGUID; out AIntf): HResult; var PIUnkItem: IUnknown; begin CriticalSection.EnterCriticalSection; try Result := GMHResultFromWin32(ERROR_INVALID_INDEX); if not GMIsInRange(APosition, 0, FCount-1) then Exit; //GMCheckIntRange(RStrArrayIndex, APosition, 0, FCount-1, Self, {$I %CurrentRoutine%}); PIUnkItem := EntryAsIntf(APosition); if PIUnkItem <> nil then Result := PIUnkItem.QueryInterface(AIID, AIntf); finally CriticalSection.LeaveCriticalSection; end; end; procedure TGMArrayCollectionBase.SetCapacity(const ANewCapacity: PtrInt); begin CriticalSection.EnterCriticalSection; try if (ANewCapacity < 0) or (ANewCapacity > cMaxPtrArraySize) then RaiseError(GMFormat(RStrListCapacityError, [ANewCapacity, cMaxPtrArraySize]), Self, 'SetCapacity'); if ANewCapacity <> FCapacity then begin ReallocMem(FEntries, ANewCapacity * SizeOf(Pointer)); FCapacity := ANewCapacity; end; finally CriticalSection.LeaveCriticalSection; end; end; procedure TGMArrayCollectionBase.Clear(const ANotify: Boolean); var i, oldCount: PtrInt; begin 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 TGMArrayCollectionBase.SetSorted(const AValue: Boolean); begin CriticalSection.EnterCriticalSection; try if AValue <> FSorted then begin FSorted := AValue; if AValue then Sort; end; finally CriticalSection.LeaveCriticalSection; end; end; procedure TGMArrayCollectionBase.AfterCompareFuncChanged; begin if Assigned(FCompareFunc) and Sorted then Sort; end; function TGMArrayCollectionBase.IndexOfPointer(const Ptr: Pointer): PtrInt; begin for Result := 0 to FCount-1 do if FEntries^[Result] = Ptr then Exit; Result := cInvalidItemIdx; end; function TGMArrayCollectionBase.IsDuplicate(const AKeyToCompare: IUnknown; var AIndex: PtrInt): Boolean; var idx: PtrInt; begin Result := False; if not FAcceptDuplicates then begin if Sorted then Result := IsValidIndex(AIndex) and (CompareEntries(EntryAsIntf(AIndex), AKeyToCompare) = crAEqualToB) else for idx:=0 to FCount-1 do if CompareEntries(EntryAsIntf(idx), AKeyToCompare) = crAEqualToB then begin AIndex := idx; Result := True; Break; end; end; end; procedure TGMArrayCollectionBase.InsertPointer(const AInstance: Pointer; const AIndex: PtrInt); begin GMCheckIntRange(RStrArrayIndex, AIndex, 0, FCount, Self, {$I %CurrentRoutine%}); if FCount = FCapacity then SetCapacity(FCapacity + GrowDelta(FCapacity)); if AIndex < FCount then System.Move(FEntries^[AIndex], FEntries^[AIndex + 1], (FCount - AIndex) * SizeOf(Pointer)); FEntries^[AIndex] := AInstance; Inc(FCount); NotifyAfterAddItem(AInstance, AIndex); NotifyAfterCountChanged(FCount-1, FCount); end; {procedure TGMArrayCollectionBase.Pack; var i: PtrInt begin 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 TGMArrayCollectionBase.LoadData(const Source: IGMValueStorage; const ACryptCtrlData: PGMCryptCtrlData); {$ELSE} procedure TGMArrayCollectionBase.LoadData(const Source: IUnknown; const ACryptCtrlData: PGMCryptCtrlData); {$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, ACryptCtrlData); end; {$IFNDEF STANDALONE_COLLECTIONS} procedure TGMArrayCollectionBase.StoreData(const Dest: IGMValueStorage; const ACryptCtrlData: PGMCryptCtrlData); {$ELSE} procedure TGMArrayCollectionBase.StoreData(const Dest: IUnknown; const ACryptCtrlData: PGMCryptCtrlData); {$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, ACryptCtrlData); end; procedure TGMArrayCollectionBase.RemoveByIdx(const AIndex: PtrInt; ADelCount: PtrInt); var i: PtrInt; begin CriticalSection.EnterCriticalSection; try GMCheckIntRange(RStrArrayIndex, AIndex, 0, FCount-1, Self, {$I %CurrentRoutine%}); ADelCount := Min(ADelCount, FCount - AIndex); if ADelCount <= 0 then Exit; // <- GMCheckIntRange should never raise with this for i:=AIndex to AIndex + ADelCount-1 do begin NotifyBeforeRemoveItem(FEntries^[i], i); if FFreeEntries then {if FEntries^[i] <> nil then} FreePointer(FEntries^[i]); end; Dec(FCount, ADelCount); if AIndex < FCount then System.Move(FEntries^[AIndex + ADelCount], FEntries^[AIndex], (FCount - AIndex) * SizeOf(Pointer)); if FCapacity - FCount >= GrowDelta(FCapacity) then SetCapacity(FCapacity - GrowDelta(FCapacity)); NotifyAfterCountChanged(FCount + ADelCount, FCount); finally CriticalSection.LeaveCriticalSection; end; end; function TGMArrayCollectionBase.CalcInsertIdx(const AKeyToCompare: IUnknown): PtrInt; function _InsertIdx(L, R: PtrInt): PtrInt; var M: PtrInt; begin //if not Assigned(CompareFunc) then Result := FCount else if L >= R then Result := L else begin M := (L + R) shr 1; case CompareEntries(AKeyToCompare, 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, {$I %CurrentRoutine%}); {$ELSE} raise Exception.Create(GMStringJoin(GMStringJoin(GMObjName(Self), cStrErrNameSep, {$I %CurrentRoutine%}), ': ', RStrInvalidCompareResult)); {$ENDIF} end; end; end; begin CriticalSection.EnterCriticalSection; try if not FSorted then Result := FCount else Result := _InsertIdx(0, FCount); finally CriticalSection.LeaveCriticalSection; end; end; function TGMArrayCollectionBase.IndexOf(const AKeyToCompare: IUnknown): PtrInt; begin CriticalSection.EnterCriticalSection; try if not Sorted then begin for Result := 0 to FCount-1 do if CompareEntries(EntryAsIntf(Result), AKeyToCompare) = crAEqualToB then Exit; Result := cInvalidItemIdx; end else begin Result := CalcInsertIdx(AKeyToCompare); if not IsValidIndex(Result) or (CompareEntries(EntryAsIntf(Result), AKeyToCompare) <> crAEqualToB) then Result := cInvalidItemIdx; end; finally CriticalSection.LeaveCriticalSection; end; end; function TGMArrayCollectionBase.IndexOfNearest(const AKeyToCompare: IUnknown): PtrInt; begin CriticalSection.EnterCriticalSection; try CheckSorted({$I %CurrentRoutine%}); Result := GMBoundedInt(CalcInsertIdx(AKeyToCompare), 0, FCount-1); if not IsValidIndex(Result) then Result := cInvalidItemIdx; finally CriticalSection.LeaveCriticalSection; end; end; function TGMArrayCollectionBase.Find(const AKeyToCompare: IUnknown; out AEntry): Boolean; var idx: PtrInt; begin CriticalSection.EnterCriticalSection; try idx := IndexOf(AKeyToCompare); Result := IsValidIndex(idx); if Result then Pointer(AEntry) := FEntries^[idx]; finally CriticalSection.LeaveCriticalSection; end; end; function TGMArrayCollectionBase.FindNearest(const AKeyToCompare: IUnknown; out AEntry): Boolean; var idx: PtrInt; begin CriticalSection.EnterCriticalSection; try idx := IndexOfNearest(AKeyToCompare); Result := IsValidIndex(idx); if Result then Pointer(AEntry) := FEntries^[idx]; finally CriticalSection.LeaveCriticalSection; end; end; function TGMArrayCollectionBase.RemoveByKey(const AKeyToCompare: IUnknown): Boolean; var idx: PtrInt; begin CriticalSection.EnterCriticalSection; try idx := IndexOf(AKeyToCompare); Result := IsValidIndex(idx); if Result then RemoveByIdx(idx); finally CriticalSection.LeaveCriticalSection; end; end; procedure TGMArrayCollectionBase.Reverse; var i: PtrInt; begin CriticalSection.EnterCriticalSection; try if FCount > 1 then for i:=0 to FCount-1 shr 1 do Exchange(i, FCount-1-i); finally CriticalSection.LeaveCriticalSection; end; end; procedure TGMArrayCollectionBase.Rotate(ADelta: PtrInt; const AStartIdx: PtrInt); var buffer: Pointer; bufferSize: PtrInt; begin if FCount < 2 then Exit; CriticalSection.EnterCriticalSection; try CheckUnsorted({$I %CurrentRoutine%}); //if Abs(ADelta) >= FCount - AStartIdx then RaiseError(GMFormat(RStrInvalidRotateDelta, [ADelta]), Self, 'Rotate'); ADelta := ADelta mod FCount; GMCheckIntRange(RStrArrayIndex, AStartIdx, 0, FCount-1, Self, {$I %CurrentRoutine%}); //if AStartIdx >= FCount then RaiseError(GMFormat(RStrInvalidRotateStartPos, [AStartIdx]), Self, 'Rotate'); // 32-Bit Release Version of "Abs" did not change -1 to 1 .. //bufferSize := GMAbsPtrInt(ADelta) * SizeOf(Pointer); bufferSize := Abs(ADelta * SizeOf(Pointer)); //vfGMTRace(GMFormat('bufferSize: %d', [bufferSize]), 'bufferSize'); buffer := GetMem(bufferSize); try if ADelta > 0 then begin //GetMem(buffer, bufferSize); //try System.Move(FEntries^[FCount-ADelta], buffer^, bufferSize); System.Move(FEntries^[AStartIdx], FEntries^[ADelta+AStartIdx], (FCount-ADelta-AStartIdx) * SizeOf(Pointer)); System.Move(buffer^, FEntries^[AStartIdx], bufferSize); //finally // FreeMem(buffer); //end; end; if ADelta < 0 then begin //GetMem(buffer, bufferSize); //try System.Move(FEntries^[AStartIdx], buffer^, bufferSize); System.Move(FEntries^[-ADelta+AStartIdx], FEntries^[AStartIdx], (FCount+ADelta-AStartIdx) * SizeOf(Pointer)); System.Move(buffer^, FEntries^[FCount+ADelta], bufferSize); //finally // FreeMem(buffer); //end; end; finally FreeMem(buffer); end; finally CriticalSection.LeaveCriticalSection; end; end; procedure TGMArrayCollectionBase.Exchange(const AIndex1, AIndex2: PtrInt); var tmpItem: Pointer; begin CriticalSection.EnterCriticalSection; try if AIndex1 <> AIndex2 then begin CheckUnsorted({$I %CurrentRoutine%}); GMCheckIntRange(RStrArrayIndex, AIndex1, 0, FCount-1, Self, {$I %CurrentRoutine%}); GMCheckIntRange(RStrArrayIndex, AIndex2, 0, FCount-1, Self, {$I %CurrentRoutine%}); tmpItem := FEntries^[AIndex1]; FEntries^[AIndex1] := FEntries^[AIndex2]; FEntries^[AIndex2] := tmpItem; end; finally CriticalSection.LeaveCriticalSection; end; end; //procedure TGMArrayCollectionBase.Move(const ASourceIdx, ADestIdx: PtrInt); //var tmpItem: Pointer; //begin // CriticalSection.EnterCriticalSection; // try // if ASourceIdx <> ADestIdx then // begin // CheckUnsorted; // GMCheckIntRange(RStrArrayIndex, ASourceIdx, 0, FCount-1, Self, {$I %CurrentRoutine%}); // GMCheckIntRange(RStrArrayIndex, ADestIdx, 0, FCount-1, Self, {$I %CurrentRoutine%}); // // tmpItem := FEntries^[ASourceIdx]; // // if ASourceIdx < ADestIdx then // System.Move(FEntries^[ASourceIdx+1], FEntries^[ASourceIdx], (ADestIdx - ASourceIdx) * SizeOf(Pointer)) // else // System.Move(FEntries^[ADestIdx], FEntries^[ADestIdx+1], (ASourceIdx - ADestIdx) * SizeOf(Pointer)); // // FEntries^[ADestIdx] := tmpItem; // end; // finally // CriticalSection.LeaveCriticalSection; // end; //end; procedure TGMArrayCollectionBase.Sort; procedure QuickSort(L, R: PtrInt); var i, j, m: PtrInt; 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 CriticalSection.EnterCriticalSection; try if (FEntries <> nil) and (FCount > 0) then QuickSort(0, FCount-1); finally CriticalSection.LeaveCriticalSection; end; end; { ---------------------------------------- } { ---- TGMArrayCollectionIteratorBase ---- } { ---------------------------------------- } function TGMArrayCollectionIteratorBase.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 TGMArrayCollectionIteratorBase.Reset; begin if FReverse then FCurrentIdx := (FCollection as TGMCollectionBase).Count-1 else FCurrentIdx := 0; end; { ------------------------------- } { ---- TGMObjArrayCollection ---- } { ------------------------------- } Constructor TGMObjArrayCollection.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 TGMObjArrayCollection.CreateIterator(const AReverse, AConcurrentThreadLock: Boolean): IGMIterator; begin Result := TGMObjectCollectionIterator.Create(Self, AConcurrentThreadLock, AReverse, True); end; function TGMObjArrayCollection.EntryAsIntf(const AIndex: PtrInt): IUnknown; begin Result := GMObjAsIntf(FEntries^[AIndex]); end; procedure TGMObjArrayCollection.FreePointer(var AItem: Pointer); begin GMFreeAndNil(TObject(AItem)); end; procedure TGMObjArrayCollection.SetOnAfterAddItem(const AValue: TGMObjItemAddRemoveProc); begin OnAfterAddItem := AValue; end; procedure TGMObjArrayCollection.NotifyAfterAddItem(const AItem: Pointer; const AIndex: PtrInt); begin if Assigned(OnAfterAddItem) then OnAfterAddItem(Self, TObject(AItem), AIndex); end; procedure TGMObjArrayCollection.SetOnBeforeRemoveItem(const Value: TGMObjItemAddRemoveProc); begin OnBeforeRemoveItem := Value; end; procedure TGMObjArrayCollection.NotifyBeforeRemoveItem(const AItem: Pointer; const AIndex: PtrInt); begin if Assigned(OnBeforeRemoveItem) then OnBeforeRemoveItem(Self, TObject(AItem), AIndex); end; function TGMObjArrayCollection.InternalInsert(const AObj: TObject; var AIndex: PtrInt; const AReplaceIfExists: Boolean): Boolean; var doInsert: Boolean; objIntf: IUnknown; begin // prevent GMObjAsIntf call when FAcceptDuplicates = true so objects without IUnknown can be added doInsert := FAcceptDuplicates; if not doInsert then begin objIntf := GMObjAsIntf(AObj); doInsert := not IsDuplicate(objIntf, AIndex); objIntf := nil; end; Result := doInsert or AReplaceIfExists; if doInsert then try InsertPointer(AObj, AIndex); except if FreeEntries then AObj.Free; raise; end else if AReplaceIfExists then begin if FreeEntries then FreePointer(FEntries^[AIndex]); FEntries^[AIndex] := AObj; end else if FreeEntries then AObj.Free; end; function TGMObjArrayCollection.ObjInsertIdx(const AObj: TObject): PtrInt; begin // CalcInsertIdx forces the added object 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 := CalcInsertIdx(GMObjAsIntf(AObj)); end; function TGMObjArrayCollection.Add(const AObj: TObject; const AReplaceIfExists: Boolean): TObject; var idx: PtrInt; begin CriticalSection.EnterCriticalSection; try idx := ObjInsertIdx(AObj); InternalInsert(AObj, idx, AReplaceIfExists); //if not InternalInsert(AObj, idx, AReplaceIfExists) and FreeEntries then AObj.Free; Result := FEntries^[idx]; finally CriticalSection.LeaveCriticalSection; end; end; function TGMObjArrayCollection.AddIdx(const AObj: TObject; const AReplaceIfExists: Boolean): PtrInt; begin CriticalSection.EnterCriticalSection; try // CalcInsertIdx forces the added AObj to have IUnknown, only mandatory when sorted. Allow normal objects to be added when not sorted Result := ObjInsertIdx(AObj); InternalInsert(AObj, Result, AReplaceIfExists); //if not InternalInsert(AObj, Result, AReplaceIfExists) and FreeEntries then AObj.Free; finally CriticalSection.LeaveCriticalSection; end; end; function TGMObjArrayCollection.Insert(const AObj: TObject; const AIndex: PtrInt; const AReplaceIfExists: Boolean): TObject; var idx: PtrInt; begin CriticalSection.EnterCriticalSection; try CheckUnsorted({$I %CurrentRoutine%}); //if FSorted then Result := Add(AObj, AReplaceIfExists) else // begin idx := AIndex; InternalInsert(AObj, idx, AReplaceIfExists); //if not InternalInsert(AObj, idx, AReplaceIfExists) and FreeEntries then AObj.Free; Result := FEntries^[idx]; //end; finally CriticalSection.LeaveCriticalSection; end; end; function TGMObjArrayCollection.GetItem(const AIndex: PtrInt): TObject; begin CriticalSection.EnterCriticalSection; try GMCheckIntRange(RStrArrayIndex, AIndex, 0, FCount-1, Self, {$I %CurrentRoutine%}); Result := FEntries^[AIndex]; finally CriticalSection.LeaveCriticalSection; end; end; procedure TGMObjArrayCollection.SetItem(const AIndex: PtrInt; const AValue: TObject); begin CriticalSection.EnterCriticalSection; try GMCheckIntRange(RStrArrayIndex, AIndex, 0, FCount-1, Self, {$I %CurrentRoutine%}); if FreeEntries then FreePointer(FEntries^[AIndex]); FEntries^[AIndex] := AValue; finally CriticalSection.LeaveCriticalSection; end; end; function TGMObjArrayCollection.First: TObject; begin CriticalSection.EnterCriticalSection; try if FCount = 0 then Result := nil else Result := GetItem(0); finally CriticalSection.LeaveCriticalSection; end; end; function TGMObjArrayCollection.Last: TObject; begin CriticalSection.EnterCriticalSection; try if FCount = 0 then Result := nil else Result := GetItem(FCount - 1); finally CriticalSection.LeaveCriticalSection; end; end; function TGMObjArrayCollection.IndexOfObj(const AObj: TObject): PtrInt; begin CriticalSection.EnterCriticalSection; try Result := IndexOfPointer(AObj); finally CriticalSection.LeaveCriticalSection; end; end; function TGMObjArrayCollection.RemoveByInstance(const AObj: TObject): Boolean; var idx: PtrInt; begin CriticalSection.EnterCriticalSection; try idx := IndexOfObj(AObj); Result := IsValidIndex(idx); if Result then RemoveByIdx(idx); finally CriticalSection.LeaveCriticalSection; end; end; {function TGMObjArrayCollection.FindObj(const Obj: TObject; var Index: LongInt): Boolean; begin CriticalSection.EnterCriticalSection; try Index := IndexOfObj(Obj); Result := IsValidIndex(Index); finally CriticalSection.LeaveCriticalSection; end; end;} { ------------------------------------- } { ---- TGMObjectCollectionIterator ---- } { ------------------------------------- } procedure TGMObjectCollectionIterator.AssignOutEntry(out AEntry); begin TObject(AEntry) := (FCollection as TGMObjArrayCollection)[FCurrentIdx]; end; { -------------------------------- } { ---- TGMIntfArrayCollection ---- } { -------------------------------- } Constructor TGMIntfArrayCollection.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 TGMIntfArrayCollection.CreateIterator(const AReverse, AConcurrentThreadLock: Boolean): IGMIterator; begin Result := TGMIntfArrayCollectionIterator.Create(Self, AConcurrentThreadLock, AReverse, True); end; function TGMIntfArrayCollection.EntryAsIntf(const AIndex: PtrInt): IUnknown; begin Result := IUnknown(FEntries^[AIndex]); end; procedure TGMIntfArrayCollection.FreePointer(var AItem: Pointer); begin //if AItem <> nil then IUnknown(AItem)._Relea<<<<<<<se; if AItem <> nil then IUnknown(AItem) := nil; // <- does a IUnknown(AItem)._Release end; procedure TGMIntfArrayCollection.SetOnAfterAddItem(const AValue: TGMIntfItemAddRemoveProc); begin OnAfterAddItem := AValue; end; procedure TGMIntfArrayCollection.NotifyAfterAddItem(const AItem: Pointer; const AIndex: PtrInt); begin if Assigned(OnAfterAddItem) then OnAfterAddItem(Self, IUnknown(AItem), AIndex); end; procedure TGMIntfArrayCollection.SetOnBeforeRemoveItem(const Value: TGMIntfItemAddRemoveProc); begin OnBeforeRemoveItem := Value; end; procedure TGMIntfArrayCollection.NotifyBeforeRemoveItem(const AItem: Pointer; const AIndex: PtrInt); begin if Assigned(OnBeforeRemoveItem) then OnBeforeRemoveItem(Self, IUnknown(AItem), AIndex); end; function TGMIntfArrayCollection.InternalInsert(const AIntf: IUnknown; var AIndex: PtrInt; const AReplaceIfExists: Boolean = False): 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, AIndex); Result := doInsert or AReplaceIfExists; if doInsert then begin InsertPointer(Pointer(unk), AIndex); unk._AddRef; end else if AReplaceIfExists then begin FreePointer(FEntries^[AIndex]); FEntries^[AIndex] := Pointer(unk); unk._AddRef; end; //else // FreePointer(AIntf); end; function TGMIntfArrayCollection.AddIdx(const AIntf: IUnknown; const AReplaceIfExists: Boolean): PtrInt; var itemHolder: IUnknown; begin CriticalSection.EnterCriticalSection; try // Without an additional reference stack cleanup after return of CalcInsertIdx may free a newly // created object (with refcount = 0) and the call to InternalInsert would cause an access violation // And itemHolder will cleanup a refcount = 0 AIntf in case of exceptions itemHolder := AIntf; Result := CalcInsertIdx(AIntf); InternalInsert(AIntf, Result, AReplaceIfExists); // if not InternalInsert(AIntf, Result, AReplaceIfExists) then Result := cInvalidItemIdx; finally CriticalSection.LeaveCriticalSection; end; end; function TGMIntfArrayCollection.Add(const AIntf: IUnknown; const AReplaceIfExists: Boolean): IUnknown; var itemHolder: IUnknown; idx: PtrInt; begin CriticalSection.EnterCriticalSection; try // Without an additional reference stack cleanup after return of CalcInsertIdx may free a newly // created object (with refcount = 0) and the call to InternalInsert would cause an access violation // And itemHolder will cleanup a refcount = 0 AIntf in case of exceptions itemHolder := AIntf; idx := CalcInsertIdx(AIntf); InternalInsert(AIntf, idx, AReplaceIfExists); // if (FCount > 0) and (idx = FCount) then Dec(idx); // <- Dupliacte, not inserted! Result := IUnknown(FEntries^[idx]); // if InternalInsert(AIntf, idx, AReplaceIfExists) then Result := IUnknown(FEntries^[idx]) else Result := AIntf; finally CriticalSection.LeaveCriticalSection; end; end; function TGMIntfArrayCollection.Insert(const AIntf: IUnknown; const AIndex: PtrInt; const AReplaceIfExists: Boolean): IUnknown; var itemHolder: IUnknown; idx: PtrInt; begin // itemHolder will cleanup a refcount = 0 AIntf in case of exceptions CriticalSection.EnterCriticalSection; try CheckUnsorted('Insert'); itemHolder := AIntf; //if FSorted then Result := Add(AIntf, AReplaceIfExists) else // begin idx := AIndex; InternalInsert(AIntf, idx, AReplaceIfExists); Result := IUnknown(FEntries^[idx]); // if InternalInsert(AIntf, idx, AReplaceIfExists) then Result := AIntf; // else Result := nil //end; finally CriticalSection.LeaveCriticalSection; end; end; function TGMIntfArrayCollection.Find(const AKeyToCompare: IUnknown; out AEntry): Boolean; var idx: PtrInt; begin CriticalSection.EnterCriticalSection; try idx := IndexOf(AKeyToCompare); Result := IsValidIndex(idx); if Result then IUnknown(AEntry) := IUnknown(FEntries^[idx]); finally CriticalSection.LeaveCriticalSection; end; end; function TGMIntfArrayCollection.FindNearest(const AKeyToCompare: IUnknown; out AEntry): Boolean; var idx: PtrInt; begin CriticalSection.EnterCriticalSection; try idx := IndexOfNearest(AKeyToCompare); Result := IsValidIndex(idx); if Result then IUnknown(AEntry) := IUnknown(FEntries^[idx]); finally CriticalSection.LeaveCriticalSection; end; end; {function TGMIntfArrayCollection.Remove(const Item: IUnknown): LongInt; begin CriticalSection.EnterCriticalSection; try Result := IndexOfObj(Item); if Result <> cInvalidItemIdx then Delete(Result); finally CriticalSection.LeaveCriticalSection; end; end;} function TGMIntfArrayCollection.GetItem(const Index: PtrInt): IUnknown; begin CriticalSection.EnterCriticalSection; try GMCheckIntRange(RStrArrayIndex, Index, 0, FCount-1, Self, {$I %CurrentRoutine%}); Result := IUnknown(FEntries^[Index]); finally CriticalSection.LeaveCriticalSection; end; end; function TGMIntfArrayCollection.First: IUnknown; begin CriticalSection.EnterCriticalSection; try if FCount = 0 then Result := nil else Result := GetItem(0); finally CriticalSection.LeaveCriticalSection; end; end; function TGMIntfArrayCollection.Last: IUnknown; begin CriticalSection.EnterCriticalSection; try if FCount = 0 then Result := nil else Result := GetItem(FCount - 1); finally CriticalSection.LeaveCriticalSection; end; end; function TGMIntfArrayCollection.IndexOfObj(const AIntf: IUnknown): PtrInt; var unk: IUnknown; begin CriticalSection.EnterCriticalSection; try if GMQueryInterface(AIntf, IUnknown, unk) then // <- Use the real IUnknown representation for proper object identification! Result := IndexOfPointer(Pointer(unk)) else Result := cInvalidItemIdx; finally CriticalSection.LeaveCriticalSection; end; end; function TGMIntfArrayCollection.RemoveByInstance(const AIntf: IUnknown): Boolean; var idx: PtrInt; begin CriticalSection.EnterCriticalSection; try idx := IndexOfObj(AIntf); Result := IsValidIndex(idx); if Result then RemoveByIdx(idx); finally CriticalSection.LeaveCriticalSection; end; end; {function TGMIntfArrayCollection.FindObj(const Intf: IUnknown; var Index: LongInt): Boolean; begin CriticalSection.EnterCriticalSection; try Index := IndexOfObj(Intf); Result := IsValidIndex(Index); finally CriticalSection.LeaveCriticalSection; end; end;} { ---------------------------------------- } { ---- TGMIntfArrayCollectionIterator ---- } { ---------------------------------------- } procedure TGMIntfArrayCollectionIterator.AssignOutEntry(out AEntry); begin IUnknown(AEntry) := (FCollection as TGMIntfArrayCollection)[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); 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; const AReplaceIfExists: Boolean): 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); 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, {$I %CurrentRoutine%}); {$ELSE} raise Exception.Create(GMStringJoin(GMStringJoin(GMObjName(ANode), cStrErrNameSep, {$I %CurrentRoutine%}), ': ', 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 AKeyToCompare: IUnknown): Boolean; var Node: TGMAvlTreeNodeBase; begin CriticalSection.EnterCriticalSection; try Node := FindNode(AKeyToCompare); 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 AKeyToCompare: IUnknown): TGMAvlTreeNodeBase; begin CriticalSection.EnterCriticalSection; try Result := Root; while Result <> nil do case CompareEntries(AKeyToCompare, Result.GetDataAsIntf) of crALessThanB: Result := Result.Left; crAEqualToB: Break; crAGreaterThanB: Result := Result.Right; end; finally CriticalSection.LeaveCriticalSection; end; end; function TGMAvlTreeBase.FindNearestNode(const AKeyToCompare: IUnknown): TGMAvlTreeNodeBase; begin CriticalSection.EnterCriticalSection; try Result := Root; while Result <> nil do case CompareEntries(AKeyToCompare, 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 AKeyToCompare: IUnknown): TGMAvlTreeNodeBase; Label GreaterThanCase; begin CriticalSection.EnterCriticalSection; try Result := Root; while Result <> nil do case CompareEntries(AKeyToCompare, 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: TGMString); 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(GMFormat(RStrWrongNodeBalanceFmt, [ANode.Balance, RightHeight-LeftHeight])); end; begin CriticalSection.EnterCriticalSection; try checkCount := 0; CheckNode(Root); if FCount <> checkCount then RaiseIntegrityException(GMFormat(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], False); 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, AReplaceIfExists) 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; //GMFreeAndNil((ANode as TGMAvlObjTreeNode).Data); // .Free; inherited FreeNode(ANode); end; function TGMAvlObjTree.Find(const AKeyToCompare: IUnknown; out AEntry): Boolean; var Node: TGMAvlTreeNodeBase; begin Node := FindNode(AKeyToCompare); Result := (Node is TGMAvlObjTreeNode) and (TGMAvlObjTreeNode(Node).Data <> nil); if Result then TObject(AEntry) := TGMAvlObjTreeNode(Node).Data; end; function TGMAvlObjTree.FindNearest(const AKeyToCompare: IUnknown; out AEntry): Boolean; var Node: TGMAvlTreeNodeBase; begin Node := FindNearestNode(AKeyToCompare); 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, AReplaceIfExists) then Result := ANewEntry else Result := nil; end; function TGMAvlIntfTree.Find(const AKeyToCompare: IUnknown; out AEntry): Boolean; var Node: TGMAvlTreeNodeBase; begin Node := FindNode(AKeyToCompare); Result := (Node is TGMAvlIntfTreeNode) and (TGMAvlIntfTreeNode(Node).Data <> nil); if Result then IUnknown(AEntry) := TGMAvlIntfTreeNode(Node).Data; end; function TGMAvlIntfTree.FindNearest(const AKeyToCompare: IUnknown; out AEntry): Boolean; var Node: TGMAvlTreeNodeBase; begin Node := FindNearestNode(AKeyToCompare); 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(GMFormat(RStrListCapacityError, [NewCapacity, cMaxPtrArraySize]), Self, 'SetCapacity'); if NewCapacity <> FCapacity then begin ReallocMem(FEntries, NewCapacity * SizeOf(Pointer)); FCapacity := NewCapacity; end; end; function TGMHashEntryBucket.CalcInsertIdx(const AKeyToCompare: IUnknown): TBucketIdx; 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(AKeyToCompare, 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, {$I %CurrentRoutine%}); {$ELSE} raise Exception.Create(GMStringJoin(GMStringJoin(GMObjName(Self), cStrErrNameSep, {$I %CurrentRoutine%}), ': ', RStrInvalidCompareResult)); {$ENDIF} end; end; end; begin Result := _InsertIdx(0, FCount); end; function TGMHashEntryBucket.FindIdxOfKey(const AKeyToCompare: IUnknown; var AIndex: TBucketIdx): Boolean; begin AIndex := CalcInsertIdx(AKeyToCompare); Result := GMIsInRange(AIndex, 0, FCount-1) and (FHashTable.CompareEntries(FHashTable.EntryAsIntf(FEntries^[AIndex]), AKeyToCompare) = crAEqualToB); end; function TGMHashEntryBucket.FindKey(const AKeyToCompare: IUnknown; out AEntry): Boolean; var idx: TBucketIdx; begin Result := FindIdxOfKey(AKeyToCompare, 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 := CalcInsertIdx(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 AKeyToCompare: IUnknown): Boolean; var idx: TBucketIdx; begin Result := FindIdxOfKey(AKeyToCompare, idx); if Result then 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): PtrInt; begin Result := (AHashCode and FHashBitMask) shr (FHashBitOffs + FMaxHashBits - FHashBitCount); end; function TGMHashBitMaskDirectory.FindDirEntry(const AHashCode: TGMHashCode): IUnknown; begin if Length(FDirEntries) = 0 then Exit{$IFDEF FPC}(nil){$ENDIF}; 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 AKeyToCompare: 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, AKeyToCompare); 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(AKeyToCompare); {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 AKeyToCompare: IUnknown): TGMHashCode; var PIHashCode: IGMHashCode; begin GMCheckQueryInterface(AKeyToCompare, 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 AKeyToCompare: IUnknown): Boolean; begin CriticalSection.EnterCriticalSection; try Result := (FRootDirectory <> nil) and FRootDirectory.Obj.RemoveByKey(BuildHashCode(AKeyToCompare), AKeyToCompare); 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 AKeyToCompare: IUnknown; out AEntry): Boolean; var PIBucket: IGMHashEntryBucket; begin CriticalSection.EnterCriticalSection; try Result := (FRootDirectory <> nil) and FRootDirectory.Obj.FindBucket(BuildHashCode(AKeyToCompare), PIBucket) and PIBucket.Obj.FindKey(AKeyToCompare, AEntry); finally CriticalSection.LeaveCriticalSection; end; end; function TGMHashTableBase.FindNearest(const AKeyToCompare: IUnknown; out AEntry): Boolean; {$IFDEF FPC}{$push}{$WARN 5033 off : Function result variable does not seem to be initialized}{$ENDIF} begin raise Exception.Create(GMFormat(RStrNoNearestInHashFmt, [ClassName])); end; {$IFDEF FPC}{$pop}{$ENDIF} 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; GMFreeAndNil(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{$IFDEF FPC}(nil){$ENDIF}; // // 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 else Result := nil; 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; {$IFDEF HAS_GENERICS} { ------------------------- } { ---- Global Routines ---- } { ------------------------- } function GMGenericCompareUsingOperators<T>(const AValueA, AValueB: T): TGMCompareResult; begin if AValueA < AValueB then Result := crALessThanB else if AValueA = AValueB then Result := crAEqualToB else Result := crAGreaterThanB end; { ----------------------------------- } { ---- TGMPlainGenericCollection ---- } { ----------------------------------- } procedure TGMPlainGenericCollection.CheckSorted(const ASortedReqired, ASorted: Boolean; const AOperationName: TGMString); begin if ASortedReqired and not ASorted then RaiseError(GMFormat(RStrCollectionNotSortedFmt, [AOperationName]), Self, cStrCheckSorted); if not ASortedReqired and ASorted then RaiseError(GMFormat(RStrCollectionSortedFmt, [AOperationName]), Self, cStrCheckUnsorted); end; function TGMPlainGenericCollection.ArrayGrowDelta(const ACurrentCapacity: PtrInt): PtrInt; begin Result := GrowDelta(ACurrentCapacity); end; function TGMPlainGenericCollection.MsgStrArrayIndex: TGMString; begin Result := RStrArrayIndex; end; { ----------------------------------- } { ---- TGMGenericIteratorBase<T> ---- } { ----------------------------------- } constructor TGMGenericIteratorBase<T>.Create(const ACollection: IUnknown; const AReverse: Boolean; const AConcurrentThreadLock: Boolean; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FCollectionHolder := ACollection; FReverse := AReverse; //if AConcurrentThreadLock then FThreadLock := TGMCriticalSectionLock.Create(ACollection); if AConcurrentThreadLock then FThreadLock.Lock(ACollection); Reset; end; { ------------------------------------- } { ---- TGMGenericCollectionBase<T> ---- } { ------------------------------------- } constructor TGMGenericCollectionBase<T>.Create(const AAcceptDuplicates: Boolean; const ACompareFunc: TGMGenericCompareFunc<T>; const AFinalizeEntryProc: TGMGenericFinalizeEntryProc<T>; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FCriticalSection := TGMCriticalSection.Create(True); FCompareFunc := ACompareFunc; FFinalizeEntryProc := AFinalizeEntryProc; FAcceptDuplicates := AAcceptDuplicates; //FContainsManagedType := IsManaged(TypeInfo(T)); end; destructor TGMGenericCollectionBase<T>.Destroy; begin Clear(False); inherited; end; function TGMGenericCollectionBase<T>.NullEntry: T; begin //if not FContainsManagedType then Result := Default(T); //FillByte(Result, SizeOf(Result), 0); end; function TGMGenericCollectionBase<T>.IsValidIndex(const AIndex: PtrInt): Boolean; begin CriticalSection.EnterCriticalSection; try Result := (AIndex >= 0) and (AIndex < FCount) finally CriticalSection.LeaveCriticalSection; end; end; procedure TGMGenericCollectionBase<T>.SetCompareFunc(const ACompareFunc: TGMGenericCompareFunc<T>); begin CriticalSection.EnterCriticalSection; try FCompareFunc := ACompareFunc; finally CriticalSection.LeaveCriticalSection; end; end; function TGMGenericCollectionBase<T>.GetCount: PtrInt; stdcall; begin CriticalSection.EnterCriticalSection; try Result := FCount; finally CriticalSection.LeaveCriticalSection; end; end; function TGMGenericCollectionBase<T>.IsEmpty: Boolean; begin CriticalSection.EnterCriticalSection; try Result := FCount <= 0; finally CriticalSection.LeaveCriticalSection; end; end; function TGMGenericCollectionBase<T>.CompareEntries(const AEntryA, AEntryB: T): TGMCompareResult; begin if Assigned(FCompareFunc) then Result := FCompareFunc(AEntryA, AEntryB) else Result := GMCompareMemory(@AEntryA, @AEntryB, SizeOf(T)); end; procedure TGMGenericCollectionBase<T>.NotifyAfterCountChanged(const AOldCount, ANewCount: PtrInt); begin if Assigned(FOnAfterCountChanged) then FOnAfterCountChanged(Self, AOldCount, ANewCount); end; procedure TGMGenericCollectionBase<T>.NotifyAfterAddItem(const AEntry: T; const AIndex: PtrInt); begin if Assigned(FOnAfterAddItem) then FOnAfterAddItem(Self, AEntry, AIndex); end; procedure TGMGenericCollectionBase<T>.NotifyBeforeRemoveItem(const AEntry: T; const AIndex: PtrInt); begin if Assigned(FOnBeforeRemoveItem) then FOnBeforeRemoveItem(Self, AEntry, AIndex); end; procedure TGMGenericCollectionBase<T>.SetOnAfterCountChanged(const AValue: TGMCountChangedProc); begin FOnAfterCountChanged := AValue; end; procedure TGMGenericCollectionBase<T>.SetOnAfterAddItem(const AValue: TGMGenericEntryAddRemoveProc<T>); begin FOnAfterAddItem := AValue; end; procedure TGMGenericCollectionBase<T>.SetOnBeforeRemoveItem(const AValue: TGMGenericEntryAddRemoveProc<T>); begin FOnBeforeRemoveItem := AValue; end; { -------------------------------------- } { ---- TGMGenericArrayCollection<T> ---- } { -------------------------------------- } constructor TGMGenericArrayCollection<T>.Create(const AAcceptDuplicates: Boolean; const ASorted: Boolean; const ACompareFunc: TGMGenericCompareFunc<T>; const AFinalizeEntryProc: TGMGenericFinalizeEntryProc<T>; const ARefLifeTime: Boolean); begin inherited Create(AAcceptDuplicates, ACompareFunc, AFinalizeEntryProc, ARefLifeTime); FSorted := ASorted; end; function TGMGenericArrayCollection<T>.GetSorted: Boolean; begin Result := FSorted; end; procedure TGMGenericArrayCollection<T>.QuickSort(L, R: PtrInt); var i, j, m: PtrInt; e: T; begin i := L; j := R; m := (L + R) shr 1; while i <= j do begin while CompareEntries(FEntries[i], FEntries[m]) = crALessThanB do Inc(i); while CompareEntries(FEntries[j], FEntries[m]) = crAGreaterThanB do Dec(j); if i <= j then begin if i <> j then // and CompareFunc(EntryAsIntf(i), EntryAsIntf(j)) <> crAEqualToB begin e := FEntries[i]; FEntries[i] := FEntries[j]; FEntries[j] := e; // <- 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; procedure TGMGenericArrayCollection<T>.Sort; begin CriticalSection.EnterCriticalSection; try if (FEntries <> nil) and (FCount > 0) then QuickSort(0, FCount-1); finally CriticalSection.LeaveCriticalSection; end; end; procedure TGMGenericArrayCollection<T>.SetSorted(const AValue: Boolean); begin CriticalSection.EnterCriticalSection; try if AValue <> FSorted then begin FSorted := AValue; if AValue then Sort; end; finally CriticalSection.LeaveCriticalSection; end; end; function TGMGenericArrayCollection<T>.GetEntry(const AIndex: PtrInt): T; begin CriticalSection.EnterCriticalSection; try GMCheckIntRange(MsgStrArrayIndex, AIndex, 0, FCount-1, Self, 'TGMGenericArrayCollection.GetEntry'); Result := FEntries[AIndex]; finally CriticalSection.LeaveCriticalSection; end; end; procedure TGMGenericArrayCollection<T>.SetEntry(const AIndex: PtrInt; const AValue: T); begin CriticalSection.EnterCriticalSection; try GMCheckIntRange(MsgStrArrayIndex, AIndex, 0, FCount-1, Self, 'TGMGenericArrayCollection.SetEntry'); if Assigned(FFinalizeEntryProc) then FFinalizeEntryProc(FEntries[AIndex]); FEntries[AIndex] := AValue; finally CriticalSection.LeaveCriticalSection; end; end; procedure TGMGenericArrayCollection<T>.SetCapacity(ANewCapacity: PtrInt); begin CriticalSection.EnterCriticalSection; try //if (ANewCapacity < 0) or (ANewCapacity > cMaxPtrArraySize) then RaiseError(GMFormat(RStrListCapacityError, [ANewCapacity, cMaxPtrArraySize]), Self, 'SetCapacity'); if ANewCapacity < 0 then ANewCapacity := 0; if ANewCapacity <> FCapacity then begin SetLength(FEntries, ANewCapacity); FCapacity := ANewCapacity; end; finally CriticalSection.LeaveCriticalSection; end; end; function TGMGenericArrayCollection<T>.CalcInsertIdx(const AEntry: T): PtrInt; function _InsertIdx(L, R: PtrInt): PtrInt; var M: PtrInt; begin //if not Assigned(CompareFunc) then Result := FCount else if L >= R then Result := L else begin M := (L + R) shr 1; case CompareEntries(AEntry, 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, {$I %CurrentRoutine%}); {$ELSE} raise Exception.Create(GMStringJoin(GMStringJoin(GMObjName(Self), cStrErrNameSep, {$I %CurrentRoutine%}), ': ', RStrInvalidCompareResult)); {$ENDIF} end; end; end; begin CriticalSection.EnterCriticalSection; try if not FSorted then Result := FCount else Result := _InsertIdx(0, FCount); finally CriticalSection.LeaveCriticalSection; end; end; function TGMGenericArrayCollection<T>.IndexOf(const AEntryToFind: T): PtrInt; begin CriticalSection.EnterCriticalSection; try if not FSorted then begin for Result := 0 to FCount-1 do if CompareEntries(FEntries[Result], AEntryToFind) = crAEqualToB then Exit; Result := cInvalidItemIdx; end else begin Result := CalcInsertIdx(AEntryToFind); if not IsValidIndex(Result) or (CompareEntries(FEntries[Result], AEntryToFind) <> crAEqualToB) then Result := cInvalidItemIdx; end; finally CriticalSection.LeaveCriticalSection; end; end; procedure TGMGenericArrayCollection<T>.InternalInsertEntry(const AEntry: T; const AIndex: PtrInt); begin GMCheckIntRange(MsgStrArrayIndex, AIndex, 0, FCount, Self, {$I %CurrentRoutine%}); if FCount = FCapacity then SetCapacity(FCapacity + ArrayGrowDelta(FCapacity)); if AIndex < FCount then System.Move(FEntries[AIndex], FEntries[AIndex + 1], (FCount - AIndex) * SizeOf(T)); FillByte(FEntries[AIndex], SizeOf(T), 0); // <- Important, following assignment will interpret this entry accordingly in case of managed types! FEntries[AIndex] := AEntry; Inc(FCount); NotifyAfterAddItem(AEntry, AIndex); NotifyAfterCountChanged(FCount-1, FCount); end; function TGMGenericArrayCollection<T>.IsDuplicate(const AEntry: T; var AIndex: PtrInt): Boolean; var idx: PtrInt; begin Result := False; if not FAcceptDuplicates then begin if FSorted then Result := IsValidIndex(AIndex) and (CompareEntries(FEntries[AIndex], AEntry) = crAEqualToB) else for idx:=0 to FCount-1 do if CompareEntries(FEntries[idx], AEntry) = crAEqualToB then begin AIndex := idx; Result := True; Break; end; end; end; function TGMGenericArrayCollection<T>.InternalInsert(const AEntry: T; var AIndex: PtrInt; const AReplaceIfExists: Boolean = False): Boolean; var doInsert: Boolean; begin doInsert := FAcceptDuplicates or not IsDuplicate(AEntry, AIndex); Result := doInsert or AReplaceIfExists; if doInsert then try InternalInsertEntry(AEntry, AIndex); except if Assigned(FFinalizeEntryProc) then FFinalizeEntryProc(AEntry); raise; end else if AReplaceIfExists then begin if Assigned(FFinalizeEntryProc) then FFinalizeEntryProc(FEntries[AIndex]); FEntries[AIndex] := AEntry; end else if Assigned(FFinalizeEntryProc) then FFinalizeEntryProc(AEntry); end; function TGMGenericArrayCollection<T>.CreateIterator(const AReverse: Boolean; const AConcurrentThreadLock: Boolean): IGMGenericIterator<T>; begin Result := TGMGenericArrayIterator<T>.Create(Self, AReverse, AConcurrentThreadLock); end; procedure TGMGenericArrayCollection<T>.SetCompareFunc(const ACompareFunc: TGMGenericCompareFunc<T>); var oldCmpFunc: TGMGenericCompareFunc<T>; begin oldCmpFunc := FCompareFunc; inherited SetCompareFunc(ACompareFunc); if Sorted and (@ACompareFunc <> @oldCmpFunc) then Sort; end; function TGMGenericArrayCollection<T>.IndexOfNearest(const AEntryToFind: T): PtrInt; begin CriticalSection.EnterCriticalSection; try CheckSorted(True, FSorted, 'IndexOfNearest'); Result := GMBoundedInt(CalcInsertIdx(AEntryToFind), 0, FCount-1); if not IsValidIndex(Result) then Result := cInvalidItemIdx; finally CriticalSection.LeaveCriticalSection; end; end; function TGMGenericArrayCollection<T>.Add(const ANewEntry: T; const AReplaceIfExists: Boolean): T; var idx: PtrInt; begin CriticalSection.EnterCriticalSection; try idx := CalcInsertIdx(ANewEntry); InternalInsert(ANewEntry, idx, AReplaceIfExists); //if not InternalInsert(ANewEntry, idx, AReplaceIfExists) and Assigned(FFinalizeEntryProc) then FFinalizeEntryProc(ANewEntry); Result := FEntries[idx]; finally CriticalSection.LeaveCriticalSection; end; end; function TGMGenericArrayCollection<T>.AddIdx(const ANewEntry: T; const AReplaceIfExists: Boolean): PtrInt; begin CriticalSection.EnterCriticalSection; try Result := CalcInsertIdx(ANewEntry); InternalInsert(ANewEntry, Result, AReplaceIfExists); //if not InternalInsert(ANewEntry, Result, AReplaceIfExists) and Assigned(FFinalizeEntryProc) then FFinalizeEntryProc(ANewEntry); finally CriticalSection.LeaveCriticalSection; end; end; function TGMGenericArrayCollection<T>.Insert(const ANewEntry: T; const AIndex: PtrInt; const AReplaceIfExists: Boolean): T; var idx: PtrInt; begin CriticalSection.EnterCriticalSection; try CheckSorted(False, FSorted, 'Insert'); //if FSorted then Result := Add(ANewEntry, AReplaceIfExists) else // begin idx := AIndex; InternalInsert(ANewEntry, idx, AReplaceIfExists); //if not InternalInsert(ANewEntry, idx, AReplaceIfExists) and Assigned(FFinalizeEntryProc) then FFinalizeEntryProc(ANewEntry); Result := FEntries[idx]; //end; finally CriticalSection.LeaveCriticalSection; end; end; function TGMGenericArrayCollection<T>.Contains(const AEntryToFind: T): Boolean; var idx: PtrInt; begin CriticalSection.EnterCriticalSection; try idx := IndexOf(AEntryToFind); Result := IsValidIndex(idx); finally CriticalSection.LeaveCriticalSection; end; end; function TGMGenericArrayCollection<T>.Find(const AEntryToFind: T; var AFoundEntry: T): Boolean; var idx: PtrInt; begin CriticalSection.EnterCriticalSection; try idx := IndexOf(AEntryToFind); Result := IsValidIndex(idx); if Result then AFoundEntry := FEntries[idx]; finally CriticalSection.LeaveCriticalSection; end; end; function TGMGenericArrayCollection<T>.FindNearest(const AEntryToFind: T; var AEntry: T): Boolean; var idx: PtrInt; begin CriticalSection.EnterCriticalSection; try idx := IndexOfNearest(AEntryToFind); Result := IsValidIndex(idx); if Result then AEntry := FEntries[idx]; finally CriticalSection.LeaveCriticalSection; end; end; procedure TGMGenericArrayCollection<T>.RemoveByIdx(const AIndex: PtrInt; ADelCount: PtrInt); var i: PtrInt; buffer: Pointer; bufferSize: Cardinal; begin CriticalSection.EnterCriticalSection; try GMCheckIntRange(MsgStrArrayIndex, AIndex, 0, FCount-1, Self, {$I %CurrentRoutine%}); ADelCount := Min(ADelCount, FCount - AIndex); if ADelCount <= 0 then Exit; // <- GMCheckIntRange should never raise with this for i:=AIndex to AIndex + ADelCount-1 do begin NotifyBeforeRemoveItem(FEntries[i], i); if Assigned(FFinalizeEntryProc) then FFinalizeEntryProc(FEntries[i]); FEntries[i] := Default(T); // <- free managed types end; Dec(FCount, ADelCount); if AIndex < FCount then begin bufferSize := ADelCount * SizeOf(T); buffer := GetMem(bufferSize); try // // Move deleted entries to the end, shrinking capacity will eventually apply automatic compiler finalization for managed types // System.Move(FEntries[AIndex], buffer^, bufferSize); System.Move(FEntries[AIndex + ADelCount], FEntries[AIndex], (FCount - AIndex) * SizeOf(T)); System.Move(buffer^, FEntries[FCount], bufferSize); finally FreeMem(buffer); end; end; if FCapacity - FCount >= ArrayGrowDelta(FCapacity) then SetCapacity(FCapacity - ArrayGrowDelta(FCapacity)); NotifyAfterCountChanged(FCount + ADelCount, FCount); finally CriticalSection.LeaveCriticalSection; end; end; function TGMGenericArrayCollection<T>.RemoveByKey(const AKeyToCompare: T): Boolean; var idx: PtrInt; begin CriticalSection.EnterCriticalSection; try idx := IndexOf(AKeyToCompare); Result := IsValidIndex(idx); if Result then RemoveByIdx(idx, 1); finally CriticalSection.LeaveCriticalSection; end; end; procedure TGMGenericArrayCollection<T>.Clear(const ANotify: Boolean); var i, oldCount: PtrInt; finalyzeEntries: Boolean; begin CriticalSection.EnterCriticalSection; try // Better free in reverse order finalyzeEntries := Assigned(FFinalizeEntryProc); if ANotify or finalyzeEntries then for i:=FCount-1 downto 0 do begin if ANotify then NotifyBeforeRemoveItem(FEntries[i], i); if finalyzeEntries then FFinalizeEntryProc(FEntries[i]); end; oldCount := FCount; SetCapacity(0); // <- will free managed types FCount := 0; if ANotify then NotifyAfterCountChanged(oldCount, 0); finally CriticalSection.LeaveCriticalSection; end; end; procedure TGMGenericArrayCollection<T>.Rotate(ADelta: PtrInt; const AStartIdx: PtrInt); var buffer: Pointer; bufferSize: PtrInt; begin if FCount < 2 then Exit; CriticalSection.EnterCriticalSection; try CheckSorted(False, FSorted, {$I %CurrentRoutine%}); //if Abs(ADelta) >= FCount - AStartIdx then RaiseError(GMFormat(RStrInvalidRotateDelta, [ADelta]), Self, 'Rotate'); ADelta := ADelta mod FCount; GMCheckIntRange(MsgStrArrayIndex, AStartIdx, 0, FCount-1, Self, {$I %CurrentRoutine%}); //if AStartIdx >= FCount then RaiseError(GMFormat(RStrInvalidRotateStartPos, [AStartIdx]), Self, 'Rotate'); bufferSize := Abs(ADelta) * SizeOf(T); buffer := GetMem(bufferSize); try if ADelta > 0 then begin //buffer := GetMem(bufferSize); //try System.Move(FEntries[FCount-ADelta], buffer^, bufferSize); System.Move(FEntries[AStartIdx], FEntries[ADelta+AStartIdx], (FCount-ADelta-AStartIdx) * SizeOf(T)); System.Move(buffer^, FEntries[AStartIdx], bufferSize); //finally // FreeMem(buffer); //end; end; if ADelta < 0 then begin //buffer := GetMem(bufferSize); //try System.Move(FEntries[AStartIdx], buffer^, bufferSize); System.Move(FEntries[AStartIdx-ADelta], FEntries[AStartIdx], (FCount+ADelta-AStartIdx) * SizeOf(T)); System.Move(buffer^, FEntries[FCount+ADelta], bufferSize); //finally // FreeMem(buffer); //end; end; finally FreeMem(buffer); end; finally CriticalSection.LeaveCriticalSection; end; end; procedure TGMGenericArrayCollection<T>.Exchange(const AIndex1, AIndex2: PtrInt); var tmpItem: T; begin CriticalSection.EnterCriticalSection; try if AIndex1 <> AIndex2 then begin CheckSorted(False, FSorted, {$I %CurrentRoutine%}); GMCheckIntRange(MsgStrArrayIndex, AIndex1, 0, FCount-1, Self, {$I %CurrentRoutine%}); GMCheckIntRange(MsgStrArrayIndex, AIndex2, 0, FCount-1, Self, {$I %CurrentRoutine%}); tmpItem := FEntries[AIndex1]; FEntries[AIndex1] := FEntries[AIndex2]; FEntries[AIndex2] := tmpItem; end; finally CriticalSection.LeaveCriticalSection; end; end; procedure TGMGenericArrayCollection<T>.Reverse; var i: PtrInt; begin CriticalSection.EnterCriticalSection; try if FCount > 1 then for i:=0 to FCount-1 shr 1 do Exchange(i, FCount-1-i); finally CriticalSection.LeaveCriticalSection; end; end; function TGMGenericArrayCollection<T>.First: T; begin CriticalSection.EnterCriticalSection; try if IsEmpty then Result := NullEntry else Result := FEntries[0]; // Low(FEntries) finally CriticalSection.LeaveCriticalSection; end; end; function TGMGenericArrayCollection<T>.Last: T; begin CriticalSection.EnterCriticalSection; try if IsEmpty then Result := NullEntry else Result := FEntries[FCount-1]; finally CriticalSection.LeaveCriticalSection; end; end; { ------------------------------------ } { ---- TGMGenericArrayIterator<T> ---- } { ------------------------------------ } constructor TGMGenericArrayIterator<T>.Create(const ACollection: IGMGenericArrayCollection<T>; const AReverse: Boolean; const AConcurrentThreadLock: Boolean; const ARefLifeTime: Boolean); begin inherited Create(ACollection, AReverse, AConcurrentThreadLock, ARefLifeTime); FCollection := ACollection; end; function TGMGenericArrayIterator<T>.NextEntry(var AEntry: T): Boolean; begin Result := FCollection.IsValidIndex(FCurrentIdx); if Result then begin AEntry := FCollection.Entries[FCurrentIdx]; if FReverse then Dec(FCurrentIdx) else Inc(FCurrentIdx); end; end; procedure TGMGenericArrayIterator<T>.Reset; begin if FReverse then FCurrentIdx := FCollection.Count-1 else FCurrentIdx := 0; end; {$ENDIF} // HAS_GENERICS { ----------------------- } { ---- TGMIntegerMap ---- } { ----------------------- } constructor TGMIntegerMap.Create(const ANotifyProc: TNotifyIntMapChangeProc; const ARefLifeTime: Boolean = False); begin inherited Create(ARefLifeTime); FChangeNotifyProc := ANotifyProc; end; destructor TGMIntegerMap.Destroy; begin SetCapacity(0); inherited Destroy; end; function TGMIntegerMap.Obj: TGMIntegerMap; begin Result := Self; end; procedure TGMIntegerMap.IntMapChanged(const AValue: PtrInt); begin if Assigned(FChangeNotifyProc) then FChangeNotifyProc(AValue); end; function TGMIntegerMap.MapIntegerOnInteger(const AMapKeyValue: PtrInt): PtrInt; begin Result := Values[AMapKeyValue]; end; function TGMIntegerMap.IsEmpty: Boolean; begin Result := Count <= 0; end; function TGMIntegerMap.GetCount: PtrInt; stdcall; begin Result := Count; end; procedure TGMIntegerMap.SetCapacity(const ANewCapacity: PtrInt); begin {TODO: Bessere Fehlermeldung} if (ANewCapacity < 0) or (ANewCapacity > cMaxIntArraySize) then RaiseError(GMFormat(RStrListCapacityError, [ANewCapacity, cMaxIntArraySize]), Self, {$I %CurrentRoutine%}); if ANewCapacity <> FCapacity then begin ReallocMem(FValues, ANewCapacity * SizeOf(PtrInt)); FCapacity := ANewCapacity; end; end; function TGMIntegerMap.GetMappedValue(AIndex: PtrInt): PtrInt; begin GMCheckIntRange(RStrMapIndex, AIndex, 0, Count-1, Self, {$I %CurrentRoutine%}); Result := FValues^[AIndex]; end; function TGMIntegerMap.CalcInsertIdx(const AValue: PtrInt): PtrInt; function _InsertIdx(L, R: PtrInt): PtrInt; var M: LongInt; begin if L >= R then Result := L else begin M := (L + R) shr 1; if AValue <= 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 AValue: PtrInt); var idx: PtrInt; begin if Assigned(OnDecideAddValue) and not OnDecideAddValue(AValue) then Exit; idx := CalcInsertIdx(AValue); if (idx = Count) or (FValues^[idx] <> AValue) then begin GMCheckIntRange(RStrMapIndex, idx, 0, FCount, Self, {$I %CurrentRoutine%}); if FCount = FCapacity then SetCapacity(FCapacity + GrowDelta(FCapacity)); if idx < FCount then System.Move(FValues^[idx], FValues^[idx + 1], (FCount - idx) * SizeOf(PtrInt)); FValues^[idx] := AValue; Inc(FCount); IntMapChanged(AValue); end; end; procedure TGMIntegerMap.RemoveByIdx(const AIndex: PtrInt); var val: PtrInt; begin GMCheckIntRange(RStrMapIndex, AIndex, 0, FCount-1, Self, {$I %CurrentRoutine%}); val := FValues^[AIndex]; Dec(FCount); if AIndex < FCount then System.Move(FValues^[AIndex + 1], FValues^[AIndex], (FCount - AIndex) * SizeOf(PtrInt)); if FCapacity - FCount >= GrowDelta(FCapacity) then SetCapacity(FCapacity - GrowDelta(FCapacity)); IntMapChanged(val); end; procedure TGMIntegerMap.Remove(const AValue: PtrInt); var idx: PtrInt; begin idx := CalcInsertIdx(AValue); if (idx < Count) and (FValues^[idx] = AValue) then RemoveByIdx(idx); end; procedure TGMIntegerMap.Toggle(const AValue: PtrInt); begin if Contains(AValue) then Remove(AValue) else Add(AValue); end; procedure TGMIntegerMap.AddRange(AValue1, AValue2: PtrInt); var i, tmp: PtrInt; begin if AValue1 > AValue2 then begin tmp := AValue1; AValue1 := AValue2; AValue2 := tmp; end; for i:=AValue1 to AValue2 do Add(i); end; procedure TGMIntegerMap.SetRange(AValue1, AValue2: PtrInt); var tmp: PtrInt; begin if AValue1 > AValue2 then begin tmp := AValue1; AValue1 := AValue2; AValue2 := tmp; end; while not IsEmpty and (FValues[0] < AValue1) do RemoveByIdx(0); while not IsEmpty and (FValues[Count-1] > AValue2) do RemoveByIdx(Count-1); AddRange(AValue1, AValue2); end; function TGMIntegerMap.Contains(const AValue: PtrInt): Boolean; var idx: PtrInt; begin idx := CalcInsertIdx(AValue); Result := (idx < Count) and (FValues^[idx] = AValue); end; procedure TGMIntegerMap.Clear(const ANotify: Boolean); var i: PtrInt; valArr: array of PtrInt; begin if ANotify then begin SetLength(valArr, Count); for i:=0 to Count-1 do valArr[i] := Values[i]; end; SetCapacity(0); FCount := 0; if ANotify then for i:=Low(valArr) to High(valArr) do IntMapChanged(valArr[i]); end; end.