|
- unit uutlGenerics;
-
- {$mode objfpc}{$H+}
- {$modeswitch advancedrecords}
-
- interface
-
- uses
- Classes, SysUtils, typinfo,
- uutlCommon, uutlArrayContainer, uutlListBase, uutlComparer, uutlAlgorithm, uutlInterfaces,
- uutlEnumerator;
-
- type
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlQueue<T> = class(
- specialize TutlArrayContainer<T>
- , specialize IEnumerable<T>
- , specialize IutlEnumerable<T>
- , specialize IutlReadOnlyArray<T>)
-
- private type
- TEnumerator = class(
- specialize TutlEnumerator<T>
- , specialize IEnumerator<T>
- , specialize IutlEnumerator<T>)
- strict private
- fOwner: TutlQueue;
- fReversed: Boolean;
- fCurrent: Integer;
-
- protected { TutlEnumerator }
- function InternalMoveNext: Boolean; override;
- procedure InternalReset; override;
-
- {$IFDEF UTL_ENUMERATORS}
- public { IutlEnumerator }
- function Reverse: IutlEnumerator; override;
- {$ENDIF}
-
- public { IEnumerator }
- function GetCurrent: T; override;
-
- public
- constructor Create(const aOwner: TutlQueue; const aReversed: Boolean);
- end;
-
- public type
- IEnumerator = specialize IEnumerator<T>;
- IutlEnumerator = specialize IutlEnumerator<T>;
-
- strict private
- fCount: Integer;
- fReadPos: Integer;
- fWritePos: Integer;
-
- function GetItem(const aIndex: Integer): T;
- procedure SetItem(const aIndex: Integer; aItem: T);
-
- protected
- function GetCount: Integer; override;
- procedure SetCount(const aValue: Integer); override;
- procedure SetCapacity(const aValue: integer); override;
-
- public { IEnumerable }
- function GetEnumerator: IEnumerator;
-
- public { IutlEnumerable }
- function GetUtlEnumerator: IutlEnumerator;
-
- public
- property Count: Integer read GetCount;
- property IsEmpty;
- property Capacity;
- property CanExpand;
- property CanShrink;
- property OwnsItems;
- property Items[const aIndex: Integer]: T read GetItem write SetItem; default;
-
- procedure Enqueue(constref aItem: T);
- function Dequeue: T;
- function Dequeue(const aFreeItem: Boolean): T;
- function Peek: T;
- procedure ShrinkToFit;
- procedure Clear;
-
- constructor Create(const aOwnsItems: Boolean);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlStack<T> = class(
- specialize TutlArrayContainer<T>
- , specialize IEnumerable<T>
- , specialize IutlEnumerable<T>
- , specialize IutlReadOnlyArray<T>)
-
- private type
- TEnumerator = class(
- specialize TutlMemoryEnumerator<T>
- , specialize IEnumerator<T>
- , specialize IutlEnumerator<T>)
- private
- fOwner: TutlStack;
-
- protected { IEnumerator }
- procedure InternalReset; override;
-
- {$IFDEF UTL_ENUMERATORS}
- public { IutlEnumerator }
- function Reverse: IutlEnumerator; override;
- {$ENDIF}
-
- public
- constructor Create(const aOwner: TutlStack; const aReversed: Boolean); reintroduce;
- end;
-
- public type
- IEnumerator = specialize IEnumerator<T>;
- IutlEnumerator = specialize IutlEnumerator<T>;
-
- strict private
- fCount: Integer;
-
- function GetItem(const aIndex: Integer): T;
- procedure SetItem(const aIndex: Integer; aValue: T);
-
- protected
- function GetCount: Integer; override;
- procedure SetCount(const aValue: Integer); override;
-
- public { IEnumerable }
- function GetEnumerator: IEnumerator;
-
- public { IutlEnumerable }
- function GetUtlEnumerator: IutlEnumerator;
-
- public
- property Count: Integer read GetCount;
- property IsEmpty;
- property Capacity;
- property CanExpand;
- property CanShrink;
- property OwnsItems;
- property Items[const aIndex: Integer]: T read GetItem write SetItem; default;
-
- procedure Push(constref aItem: T);
- function Pop: T;
- function Pop(const aFreeItem: Boolean): T;
- function Peek: T;
- procedure ShrinkToFit;
- procedure Clear;
-
- constructor Create(const aOwnsItems: Boolean);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlSimpleList<T> = class(
- specialize TutlListBase<T>
- , specialize IutlReadOnlyArray<T>
- , specialize IutlArray<T>)
-
- strict private
- function GetFirst: T;
- function GetLast: T;
-
- public
- property First: T read GetFirst;
- property Last: T read GetLast;
-
- property Items[const aIndex: Integer]: T read GetItem write SetItem; default;
-
- function Add (constref aItem: T): Integer;
- procedure Insert (const aIndex: Integer; constref aItem: T);
- procedure Exchange (const aIndex1, aIndex2: Integer);
- procedure Move (const aCurrentIndex, aNewIndex: Integer);
- procedure Delete (const aIndex: Integer);
- function Extract (const aIndex: Integer): T;
-
- procedure PushFirst (constref aItem: T);
- function PopFirst (const aFreeItem: Boolean): T;
-
- procedure PushLast (constref aItem: T);
- function PopLast (const aFreeItem: Boolean): T;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlCustomList<T> = class(
- specialize TutlSimpleList<T>)
-
- public type
- IEqualityComparer = specialize IutlEqualityComparer<T>;
-
- strict private
- fEqualityComparer: IEqualityComparer;
-
- public
- function IndexOf (const aItem: T): Integer;
- function Extract (const aItem: T; const aDefault: T): T; overload;
- function Remove (const aItem: T): Integer;
-
- constructor Create (aEqualityComparer: IEqualityComparer; const aOwnsItems: Boolean);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlList<T> = class(
- specialize TutlCustomList<T>)
-
- public type
- TEqualityComparer = specialize TutlEqualityComparer<T>;
-
- public
- constructor Create(const aOwnsItems: Boolean);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlCustomHashSet<T> = class(
- specialize TutlListBase<T>
- , specialize IutlReadOnlyArray<T>)
-
- private type
- TBinarySearch = specialize TutlBinarySearch<T>;
-
- public type
- IComparer = specialize IutlComparer<T>;
-
- strict private
- fComparer: IComparer;
-
- protected
- procedure SetCount (const aValue: Integer); override;
- procedure SetItem (const aIndex: Integer; aValue: T); override;
-
- public
- property Count: Integer read GetCount;
- property Items[const aIndex: Integer]: T read GetItem write SetItem; default;
-
- function Add (constref aItem: T): Boolean;
- function Contains (constref aItem: T): Boolean;
- function IndexOf (constref aItem: T): Integer;
- function Remove (constref aItem: T; const aFreeItem: Boolean = true): Boolean;
- procedure Delete (const aIndex: Integer);
-
- constructor Create (aComparer: IComparer; const aOwnsItems: Boolean);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlHashSet<T> = class(
- specialize TutlCustomHashSet<T>)
-
- public type
- TComparer = specialize TutlComparer<T>;
-
- public
- constructor Create(const aOwnsItems: Boolean);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlCustomMap<TKey, TValue> = class(
- TutlInterfaceNoRefCount
- , specialize IutlEnumerable<TValue>)
-
- public type
- ////////////////////////////////////////////////////////////////////////////////////////////////
- TKeyValuePair = packed record
- Key: TKey;
- Value: TValue;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////
- IValueEnumerator = specialize IEnumerator<TValue>;
- IutlValueEnumerator = specialize IutlEnumerator<TValue>;
- IKeyEnumerator = specialize IEnumerator<TKey>;
- IutlKeyEnumerator = specialize IutlEnumerator<TKey>;
- IKeyValuePairEnumerator = specialize IEnumerator<TKeyValuePair>;
- IutlKeyValuePairEnumerator = specialize IutlEnumerator<TKeyValuePair>;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////
- THashSet = class(
- specialize TutlCustomHashSet<TKeyValuePair>)
-
- strict private
- fOwner: TutlCustomMap;
-
- protected
- procedure Release(var aItem: TKeyValuePair; const aFreeItem: Boolean); override;
-
- public
- constructor Create(const aOwner: TutlCustomMap; aComparer: IComparer);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////
- IComparer = specialize IutlComparer<TKey>;
- TKeyValuePairComparer = class(
- TInterfacedObject
- , THashSet.IComparer)
-
- strict private
- fComparer: IComparer;
-
- public { IutlEqualityComparer }
- function EqualityCompare(constref i1, i2: TKeyValuePair): Boolean;
-
- public { IutlComparer }
- function Compare(constref i1, i2: TKeyValuePair): Integer;
-
- public
- constructor Create(aComparer: IComparer);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////
- TKeyEnumerator = class(
- specialize TutlEnumerator<TKey>
- , IKeyEnumerator
- , IutlKeyEnumerator)
-
- strict private
- fEnumerator: IutlKeyValuePairEnumerator;
-
- protected { TutlEnumerator }
- function InternalMoveNext: Boolean; override;
- procedure InternalReset; override;
-
- public { IEnumerator }
- function GetCurrent: TKey; override;
-
- public
- constructor Create(aEnumerator: IutlKeyValuePairEnumerator);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////
- TValueEnumerator = class(
- specialize TutlEnumerator<TValue>
- , IValueEnumerator
- , IutlValueEnumerator)
-
- strict private
- fEnumerator: IutlKeyValuePairEnumerator;
-
- protected { TutlEnumerator }
- function InternalMoveNext: Boolean; override;
- procedure InternalReset; override;
-
- public { IEnumerator }
- function GetCurrent: TValue; override;
-
- public
- constructor Create(aEnumerator: IutlKeyValuePairEnumerator);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////
- TKeyCollection = class(
- TutlInterfaceNoRefCount
- , specialize IutlReadOnlyArray<TKey>
- , specialize IutlEnumerable<TKey>)
-
- strict private
- fHashSet: THashSet;
-
- public { IEnumerable }
- function GetEnumerator: IKeyEnumerator;
-
- public { IutlEnumerable }
- function GetUtlEnumerator: IutlKeyEnumerator;
-
- public { IutlReadOnlyArray }
- function GetCount: Integer;
- function GetItem(const aIndex: Integer): TKey;
-
- property Count: Integer read GetCount;
- property Items[const aIndex: Integer]: TKey read GetItem; default;
-
- public
- constructor Create(const aHashSet: THashSet);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////
- TKeyValuePairCollection = class(
- TutlInterfaceNoRefCount
- , specialize IutlReadOnlyArray<TKeyValuePair>
- , specialize IutlEnumerable<TKeyValuePair>)
-
- strict private
- fHashSet: THashSet;
-
- public { IEnumerable }
- function GetEnumerator: IKeyValuePairEnumerator;
-
- public { IutlEnumerable }
- function GetUtlEnumerator: IutlKeyValuePairEnumerator;
-
- public { IutlReadOnlyArray }
- function GetCount: Integer;
- function GetItem(const aIndex: Integer): TKeyValuePair;
-
- property Count: Integer read GetCount;
- property Items[const aIndex: Integer]: TKeyValuePair read GetItem; default;
-
- public
- constructor Create(const aHashSet: THashSet);
- end;
-
- strict private
- fAutoCreate: Boolean;
- fOwnsKeys: Boolean;
- fOwnsValues: Boolean;
- fHashSetRef: THashSet;
- fKeyCollection: TKeyCollection;
- fKeyValuePairCollection: TKeyValuePairCollection;
-
- function GetValue (aKey: TKey): TValue; inline;
- function GetValueAt (const aIndex: Integer): TValue; inline;
- function GetCount: Integer; inline;
- function GetIsEmpty: Boolean; inline;
- function GetCapacity: Integer; inline;
- function GetCanShrink: Boolean; inline;
- function GetCanExpand: Boolean; inline;
-
- procedure SetCapacity (const aValue: Integer); inline;
- procedure SetCanShrink (const aValue: Boolean); inline;
- procedure SetCanExpand (const aValue: Boolean); inline;
-
- protected
- procedure SetValue (aKey: TKey; const aValue: TValue); virtual;
- procedure SetValueAt (const aIndex: Integer; const aValue: TValue); virtual;
-
- public { IEnumerable }
- function GetEnumerator: IValueEnumerator;
-
- public { IutlEnumerable }
- function GetUtlEnumerator: IutlValueEnumerator;
-
- public
- property Values [aKey: TKey]: TValue read GetValue write SetValue; default;
- property ValueAt[const aIndex: Integer]: TValue read GetValueAt write SetValueAt;
-
- property Keys: TKeyCollection read fKeyCollection;
- property KeyValuePairs: TKeyValuePairCollection read fKeyValuePairCollection;
-
- property Count: Integer read GetCount;
- property IsEmpty: Boolean read GetIsEmpty;
- property Capacity: Integer read GetCapacity write SetCapacity;
- property CanShrink: Boolean read GetCanShrink write SetCanShrink;
- property CanExpand: Boolean read GetCanExpand write SetCanExpand;
- property OwnsKeys: Boolean read fOwnsKeys write fOwnsKeys;
- property OwnsValues: Boolean read fOwnsValues write fOwnsValues;
- property AutoCreate: Boolean read fAutoCreate write fAutoCreate;
-
- procedure Add (constref aKey: TKey; constref aValue: TValue);
- function TryAdd (constref aKey: TKey; constref aValue: TValue): Boolean;
- function TryGetValue (constref aKey: TKey; out aValue: TValue): Boolean;
- function IndexOf (constref aKey: TKey): Integer;
- function Contains (constref aKey: TKey): Boolean;
- function Remove (constref aKey: TKey; const aFreeItem: Boolean = true): Boolean;
- procedure Delete (constref aKey: TKey);
- procedure DeleteAt (const aIndex: Integer);
- procedure Clear;
-
- constructor Create(const aHashSet: THashSet; const aOwnsKeys: Boolean; const aOwnsValues: Boolean);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlMap<TKey, TValue> = class(
- specialize TutlCustomMap<TKey, TValue>)
-
- public type
- TComparer = specialize TutlComparer<TKey>;
-
- strict private
- fHashSetImpl: THashSet;
-
- public
- constructor Create(const aOwnsKeys: Boolean; const aOwnsValues: Boolean);
- destructor Destroy; override;
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlHandle = QWord;
- generic TutlHandleManager<T> = class(
- TutlInterfacedObject
- , specialize IutlEnumerable<TutlHandle>)
-
- private type
- THandleData = packed record
- case Integer of
- 0: (
- Handle: TutlHandle // 0..63
- );
-
- 1: (
- Index: Cardinal; // 0..31 index in data array (unique for each priority)
- Counter: Word; // 32..47 reusage counter
- TypeID: Byte; // 48..55 Stored Data Type
- Priority: Byte; // 56..63 Priority to share handles between multiple systems
- );
- end;
-
- TIndex = Cardinal;
- TEntryStatus = byte;
- PHandleEntry = ^THandleEntry;
- THandleEntry = packed record
- Next: TIndex; // 0..31 next used/free item
- Prev: TIndex; // 32..63 prev used/free item
- Counter: Word; // 64..79 current counter value
- Status: TEntryStatus; // 80..87 item status
- TypeID: Byte; // 88..95 type id
- Data: T; // actual data
- end;
-
- THandleEntries = array of THandleEntry;
- PPriorityItem = ^TPriorityItem;
- TPriorityItem = packed record
- FirstFree: TIndex;
- LastFree: TIndex;
- FirstUsed: TIndex;
- LastUsed: TIndex;
- Handles: THandleEntries;
-
- function GetHandleEntry(const aIndex: TIndex): PHandleEntry;
- procedure Grow(const aSize: Integer = 0);
-
- procedure PushFront(const aIndex: TIndex; var FirstIndex, LastIndex: TIndex; const aStatus: TEntryStatus);
- procedure PushBack (const aIndex: TIndex; var FirstIndex, LastIndex: TIndex; const aStatus: TEntryStatus);
- procedure Remove (const aIndex: TIndex; var FirstIndex, LastIndex: TIndex; const aStatus: TEntryStatus);
-
- function PopFront(var FirstIndex, LastIndex: TIndex; const aStatus: TEntryStatus; const aCanGrow: Boolean): TIndex;
- function PopBack (var FirstIndex, LastIndex: TIndex; const aStatus: TEntryStatus; const aCanGrow: Boolean): TIndex;
-
- procedure PushFrontFreeIndex(const aIndex: TIndex); inline;
- procedure PushBackFreeIndex (const aIndex: TIndex); inline;
- procedure PushFrontUsedIndex(const aIndex: TIndex); inline;
- procedure PushBackUsedIndex (const aIndex: TIndex); inline;
- procedure RemoveFreeIndex (const aIndex: TIndex); inline;
- procedure RemoveUsedIndex (const aIndex: TIndex); inline;
-
- function PopFrontFreeIndex: TIndex;
- function PopBackFreeIndex: TIndex;
- function PopFrontUsedIndex: TIndex;
- function PopBackUsedIndex: TIndex;
- end;
-
- TPriorityItems = array of TPriorityItem;
-
- TEnumerator = class(specialize TutlEnumerator<TutlHandle>)
- private
- fOwner: TutlHandleManager;
- fPriority: Integer;
- fIndex: TIndex;
- fHandle: THandleEntry;
-
- protected
- function InternalMoveNext: Boolean; override;
- procedure InternalReset; override;
-
- public
- function GetCurrent: TutlHandle; override;
-
- constructor Create(const aOwner: TutlHandleManager);
- end;
-
- private const
- UNKNOWN_INDEX: TIndex = high(TIndex);
- GROW_SIZE = 100;
-
- ENTRY_STATUS_UNKNOWN: byte = 0;
- ENTRY_STATUS_FREE: byte = 1;
- ENTRY_STATUS_USED: byte = 2;
-
- private
- class function HighIndex(constref aEntries: THandleEntries): TIndex; inline;
-
- public type
- IEnumerator = specialize IEnumerator<TutlHandle>;
- IutlEnumerator = specialize IutlEnumerator<TutlHandle>;
-
- private
- fCount: Integer;
- fItems: TPriorityItems;
- fOwnsValues: Boolean;
-
- function GetPriorityItem(const aPriority: Byte): PPriorityItem;
-
- public
- function GetValue (const aHandle: TutlHandle): T;
- function TryGetValue (const aHandle: TutlHandle; out aData: T): Boolean;
- procedure SetValue (const aHandle: TutlHandle; aData: T);
- function TrySetValue (const aHandle: TutlHandle; aData: T): Boolean;
- function Add (const aTypeID: Byte; const aPriority: Byte; constref aData: T): TutlHandle;
- function IsValid (const aHandle: TutlHandle): Boolean; inline;
- procedure Update (const aHandle: TutlHandle; aData: T);
- function Remove (const aHandle: TutlHandle): Boolean;
- procedure Delete (const aHandle: TutlHandle);
- procedure Clear;
-
- public { IutlEnumerable }
- function GetEnumerator: IEnumerator;
- function GetUtlEnumerator: IutlEnumerator;
-
- public
- property Items[const aHandle: TutlHandle]: T read GetValue write SetValue; default;
- property Count: Integer read fCount;
-
- constructor Create(const aOwnsValues: Boolean);
- destructor Destroy; override;
-
- public
- class function GetTypeID (const aHandle: TutlHandle): Byte; inline;
- class function GetPriority(const aHandle: TutlHandle): Byte; inline;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- EEnumConvertException = class(EConvertError)
- public
- constructor Create(const aValue, aExpectedType: String);
- end;
-
- TutlEnumHelperBaseClass = class of TutlEnumHelperBase;
- TutlEnumHelperBase = class
- public type
- TIntArray = array of Integer;
- TStringArray = array of String;
-
- private type
- TValuesMap = specialize TutlMap<string, TIntArray>;
- TNamesMap = specialize TutlMap<string, TStringArray>;
-
- private class var
- fValuesMap: TValuesMap;
- fNamesMap: TNamesMap;
-
- protected
- class procedure RegisterType (const aValues: TIntArray; const aNames: TStringArray);
- class procedure UnregisterType();
-
- public
- class function ToString (const aValue: Integer; const aAllowOrd: Boolean = false): String; reintroduce;
- class function TryToEnum (const aStr: String; out aValue: Integer; const aAllowOrd: Boolean = false): Boolean;
- class function ToEnum (const aStr: String; const aAllowOrd: Boolean = false): Integer; overload;
- class function ToEnum (const aStr: String; const aDefault: Integer; const aAllowOrd: Boolean = false): Integer; overload;
-
- class function IntValues: TIntArray;
- class function Names: TStringArray;
-
- public
- class constructor Initialize;
- class destructor Finalize;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlEnumHelper<T> = class(TutlEnumHelperBase)
- public type
- TEnumType = T;
- TValueArray = array of T;
-
- private class var
- fValues: TValueArray;
- fNames: TStringArray;
- fIntValues: TIntArray;
- fTypeInfo: PTypeInfo;
-
- public
- class function ToString (const aValue: T; const aAllowOrd: Boolean = false): String; reintroduce;
- class function TryToEnum (const aStr: String; out aValue: T; const aAllowOrd: Boolean = false): Boolean;
- class function ToEnum (const aStr: String; const aAllowOrd: Boolean = false): T; overload;
- class function ToEnum (const aStr: String; const aDefault: T; const aAllowOrd: Boolean = false): T; overload;
-
- class function Values: TValueArray; inline;
- class function IntValues: TIntArray; inline;
- class function Names: TStringArray; inline;
- class function TypeInfo: PTypeInfo; inline;
-
- class constructor Initialize;
- class destructor Finalize;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlSetHelperBase = class
- private type
- TEnumHelperMap = specialize TutlMap<string, TutlEnumHelperBaseClass>;
-
- private class var
- fEnumHelpers: TEnumHelperMap;
-
- private
- class function IsSet (const aSet; const aSize: Integer; const aValue: Integer): Boolean;
- class procedure SetValue (var aSet; const aSize: Integer; const aValue: Integer);
- class procedure ClearValue(var aSet; const aSize: Integer; const aValue: Integer);
-
- protected
- class procedure RegisterEnumHelper(const aHelper: TutlEnumHelperBaseClass);
- class procedure UnregisterEnumHelper;
-
- public
- class function ToString(
- const aSet;
- const aSize: Integer;
- const aSeparator: String = ', ';
- const aAllowOrd: Boolean = false): String; reintroduce;
-
- class function TryToSet(
- const aStr: String;
- out aSet;
- const aSize: Integer;
- const aAllowOrd: Boolean = false): Boolean;
-
- class function TryToSet(
- const aStr: String;
- const aSeparator: String;
- out aSet;
- const aSize: Integer;
- const aAllowOrd: Boolean = false): Boolean;
-
- class function Compare(
- const aSet1;
- const aSet2;
- const aSize: Integer): Integer;
-
- class function EnumHelper: TutlEnumHelperBaseClass;
-
- class constructor Initialize;
- class destructor Finalize;
- end;
- TutlSetHelperBaseClass = class of TutlSetHelperBase;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlSetHelper<TEnum, TSet> = class(TutlSetHelperBase)
- public type
- TEnumHelper = specialize TutlEnumHelper<TEnum>;
- TEnumType = TEnum;
- TSetType = TSet;
-
- public
- class function ToString(
- const aValue: TSet;
- const aSeparator: String = ', ';
- const aAllowOrd: Boolean = false): String; overload;
-
- class function TryToSet(
- const aStr: String;
- out aValue: TSet;
- const aAllowOrd: Boolean = false): Boolean; overload;
-
- class function TryToSet(
- const aStr: String;
- const aSeparator: String;
- out aValue: TSet;
- const aAllowOrd: Boolean = false): Boolean; overload;
-
- class function ToSet(
- const aStr: String;
- const aDefault: TSet;
- const aAllowOrd: Boolean = false): TSet; overload;
-
- class function ToSet(
- const aStr: String;
- const aAllowOrd: Boolean = false): TSet; overload;
-
- class function Compare(
- const aSet1, aSet2: TSet): Integer; overload;
-
- class constructor Initialize;
- class destructor Finalize;
- end;
-
- implementation
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlQueue.TEnumerator/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlQueue.TEnumerator.InternalMoveNext: Boolean;
- begin
- if fReversed
- then dec(fCurrent)
- else inc(fCurrent);
- result := (0 <= fCurrent) and (fCurrent < fOwner.Count);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlQueue.TEnumerator.InternalReset;
- begin
- if fReversed
- then fCurrent := fOwner.Count
- else fCurrent := -1;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- {$IFDEF UTL_ENUMERATORS}
- function TutlQueue.TEnumerator.Reverse: IutlEnumerator;
- begin
- result := TEnumerator.Create(fOwner, not fReversed);
- end;
- {$ENDIF}
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlQueue.TEnumerator.GetCurrent: T;
- begin
- result := fOwner[fCurrent];
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlQueue.TEnumerator.Create(const aOwner: TutlQueue; const aReversed: Boolean);
- begin
- if not Assigned(aOwner) then
- raise EArgumentNilException.Create('aOwner');
- fOwner := aOwner;
- fReversed := aReversed;
- inherited Create;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlQueue/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlQueue.GetItem(const aIndex: Integer): T;
- var
- i: Integer;
- begin
- if (aIndex < 0) or (aIndex >= fCount) then
- raise EOutOfRangeException.Create(aIndex, 0, fCount-1);
- i := fReadPos + aIndex;
- if (i >= Capacity) then
- i := i - Capacity;
- result := GetInternalItem(i)^;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlQueue.SetItem(const aIndex: Integer; aItem: T);
- var
- i: Integer;
- begin
- if (aIndex < 0) or (aIndex >= fCount) then
- raise EOutOfRangeException.Create(aIndex, 0, fCount-1);
- i := fReadPos + aIndex;
- if (i >= Capacity) then
- i := i - Capacity;
- GetInternalItem(i)^ := aItem;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlQueue.GetCount: Integer;
- begin
- result := fCount;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlQueue.SetCount(const aValue: Integer);
- begin
- raise ENotSupportedException.Create('SetCount not supported');
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlQueue.SetCapacity(const aValue: integer);
- var
- cnt: Integer;
- begin
- if (aValue < Count) then
- raise EArgumentException.Create('can not reduce capacity below count');
-
- if (aValue < Capacity) then begin // is shrinking
- if (fReadPos <= fWritePos) then begin // ReadPos Before WritePos -> Move To Begin
- System.Move(GetInternalItem(fReadPos)^, GetInternalItem(0)^, SizeOf(T) * Count);
- fReadPos := 0;
- fWritePos := Count;
- end else if (fReadPos > fWritePos) then begin // ReadPos Behind WritePos
- cnt := Capacity - aValue;
- System.Move(GetInternalItem(fReadPos)^, GetInternalItem(fReadPos - cnt)^, SizeOf(T) * cnt);
- dec(fReadPos, cnt);
- end;
- end;
-
- inherited SetCapacity(aValue);
-
- // ReadPos After WritePos and Expanding
- if (fReadPos > fWritePos) and (aValue > Capacity) then begin
- cnt := aValue - Capacity;
- System.Move(GetInternalItem(fReadPos)^, GetInternalItem(fReadPos - cnt)^, SizeOf(T) * cnt);
- inc(fReadPos, cnt);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlQueue.GetEnumerator: IEnumerator;
- begin
- result := TEnumerator.Create(self, false);
- result.Reset;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlQueue.GetUtlEnumerator: IutlEnumerator;
- begin
- result := TEnumerator.Create(self, false);
- result.Reset;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlQueue.Enqueue(constref aItem: T);
- begin
- if (Count = Capacity) then
- Expand;
- fWritePos := fWritePos mod Capacity;
- GetInternalItem(fWritePos)^ := aItem;
- inc(fCount);
- inc(fWritePos);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlQueue.Dequeue: T;
- begin
- result := Dequeue(false);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlQueue.Dequeue(const aFreeItem: Boolean): T;
- var
- p: PT;
- begin
- if IsEmpty then
- raise EInvalidOperation.Create('queue is empty');
- p := GetInternalItem(fReadPos);
- if aFreeItem
- then FillByte(result{%H-}, SizeOf(result), 0)
- else result := p^;
- Release(p^, aFreeItem);
- dec(fCount);
- fReadPos := (fReadPos + 1) mod Capacity;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlQueue.Peek: T;
- begin
- if IsEmpty then
- raise EInvalidOperation.Create('queue is empty');
- result := GetInternalItem(fReadPos)^;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlQueue.ShrinkToFit;
- begin
- Shrink(true);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlQueue.Clear;
- begin
- while (fReadPos <> fWritePos) do begin
- Release(GetInternalItem(fReadPos)^, true);
- fReadPos := (fReadPos + 1) mod Capacity;
- end;
- fCount := 0;
- if CanShrink then
- ShrinkToFit;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlQueue.Create(const aOwnsItems: Boolean);
- begin
- inherited Create(aOwnsItems);
- fCount := 0;
- fReadPos := 0;
- fWritePos := 0;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlQueue.Destroy;
- begin
- Clear;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlStack.TEnumerator/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlStack.TEnumerator.InternalReset;
- begin
- First := 0;
- Last := fOwner.Count-1;
- if (Last >= First)
- then Memory := fOwner.GetInternalItem(0)
- else Memory := nil;
- inherited InternalReset;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- {$IFDEF UTL_ENUMERATORS}
- function TutlStack.TEnumerator.Reverse: IutlEnumerator;
- begin
- result := TEnumerator.Create(fOwner, not Reversed);
- end;
- {$ENDIF}
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlStack.TEnumerator.Create(const aOwner: TutlStack; const aReversed: Boolean);
- begin
- if not Assigned(aOwner) then
- raise EArgumentNilException.Create('aOwner');
- fOwner := aOwner;
- inherited Create(nil, aReversed, 0, -1);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlStack/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlStack.GetItem(const aIndex: Integer): T;
- begin
- if (aIndex < 0) or (aIndex >= fCount) then
- raise EOutOfRangeException.Create(aIndex, 0, fCount-1);
- result := GetInternalItem(aIndex)^;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlStack.SetItem(const aIndex: Integer; aValue: T);
- begin
- if (aIndex < 0) or (aIndex >= fCount) then
- raise EOutOfRangeException.Create(aIndex, 0, fCount-1);
- GetInternalItem(aIndex)^ := aValue;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlStack.GetCount: Integer;
- begin
- result := fCount;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlStack.SetCount(const aValue: Integer);
- begin
- raise ENotSupportedException.Create('SetCount not supported');
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlStack.GetEnumerator: IEnumerator;
- begin
- result := TEnumerator.Create(self, false);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlStack.GetUtlEnumerator: IutlEnumerator;
- begin
- result := TEnumerator.Create(self, false);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlStack.Push(constref aItem: T);
- begin
- if (Count = Capacity) then
- Expand;
- GetInternalItem(fCount)^ := aItem;
- inc(fCount);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlStack.Pop: T;
- begin
- Pop(false);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlStack.Pop(const aFreeItem: Boolean): T;
- var
- p: PT;
- begin
- if IsEmpty then
- raise EInvalidOperation.Create('stack is empty');
- p := GetInternalItem(fCount-1);
- if aFreeItem
- then FillByte(result{%H-}, SizeOf(result), 0)
- else result := p^;
- Release(p^, aFreeItem);
- dec(fCount);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlStack.Peek: T;
- begin
- if IsEmpty then
- raise EInvalidOperation.Create('stack is empty');
- result := GetInternalItem(fCount-1)^;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlStack.ShrinkToFit;
- begin
- Shrink(true);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlStack.Clear;
- begin
- while (fCount > 0) do begin
- dec(fCount);
- Release(GetInternalItem(fCount)^, true);
- end;
- if CanShrink then
- ShrinkToFit;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlStack.Create(const aOwnsItems: Boolean);
- begin
- inherited Create(aOwnsItems);
- fCount := 0
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlStack.Destroy;
- begin
- Clear;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlSimpleList////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlSimpleList.GetFirst: T;
- begin
- if IsEmpty then
- raise EInvalidOperation.Create('list is empty');
- result := GetInternalItem(0)^;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlSimpleList.GetLast: T;
- begin
- if IsEmpty then
- raise EInvalidOperation.Create('list is empty');
- result := GetInternalItem(Count-1)^;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlSimpleList.Add(constref aItem: T): Integer;
- begin
- result := Count;
- InsertIntern(result, aItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSimpleList.Insert(const aIndex: Integer; constref aItem: T);
- begin
- InsertIntern(aIndex, aItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSimpleList.Exchange(const aIndex1, aIndex2: Integer);
- var
- tmp: T;
- p1, p2: PT;
- begin
- if (aIndex1 < 0) or (aIndex1 >= Count) then
- raise EOutOfRangeException.Create(aIndex1, 0, Count-1);
- if (aIndex2 < 0) or (aIndex2 >= Count) then
- raise EOutOfRangeException.Create(aIndex2, 0, Count-1);
- p1 := GetInternalItem(aIndex1);
- p2 := GetInternalItem(aIndex2);
- System.Move(p1^, tmp{%H-}, SizeOf(T));
- System.Move(p2^, p1^, SizeOf(T));
- System.Move(tmp, p2^, SizeOf(T));
- FillByte(tmp, SizeOf(tmp), 0)
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSimpleList.Move(const aCurrentIndex, aNewIndex: Integer);
- var
- tmp: T;
- cur, new: PT;
- begin
- if (aCurrentIndex < 0) or (aCurrentIndex >= Count) then
- raise EOutOfRangeException.Create(aCurrentIndex, 0, Count-1);
- if (aNewIndex < 0) or (aNewIndex >= Count) then
- raise EOutOfRangeException.Create(aNewIndex, 0, Count-1);
- if (aCurrentIndex = aNewIndex) then
- exit;
- cur := GetInternalItem(aCurrentIndex);
- new := GetInternalItem(aNewIndex);
- System.Move(cur^, tmp{%H-}, SizeOf(T));
- if (aNewIndex > aCurrentIndex) then begin
- System.Move((cur+1)^, cur^, SizeOf(T) * (aNewIndex - aCurrentIndex));
- end else begin
- System.Move(new^, (new+1)^, SizeOf(T) * (aCurrentIndex - aNewIndex));
- end;
- System.Move(tmp, new^, SizeOf(T));
- FillByte(tmp, SizeOf(tmp), 0);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSimpleList.Delete(const aIndex: Integer);
- begin
- DeleteIntern(aIndex, true);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlSimpleList.Extract(const aIndex: Integer): T;
- begin
- result := GetItem(aIndex);
- DeleteIntern(aIndex, false);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSimpleList.PushFirst(constref aItem: T);
- begin
- InsertIntern(0, aItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlSimpleList.PopFirst(const aFreeItem: Boolean): T;
- begin
- if aFreeItem
- then FillByte(result{%H-}, SizeOf(result), 0)
- else result := GetItem(0);
- DeleteIntern(0, aFreeItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSimpleList.PushLast(constref aItem: T);
- begin
- InsertIntern(Count, aItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlSimpleList.PopLast(const aFreeItem: Boolean): T;
- begin
- if aFreeItem
- then FillByte(result{%H-}, SizeOf(result), 0)
- else result := GetItem(Count-1);
- DeleteIntern(Count-1, aFreeItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlCustomList////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomList.IndexOf(const aItem: T): Integer;
- begin
- result := Count-1;
- while (result >= 0)
- and not fEqualityComparer.EqualityCompare(Items[result], aItem)
- do
- dec(result);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomList.Extract(const aItem: T; const aDefault: T): T;
- var
- i: Integer;
- begin
- i := IndexOf(aItem);
- if (i >= 0) then begin
- result := Items[i];
- DeleteIntern(i, false);
- end else
- result := aDefault;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomList.Remove(const aItem: T): Integer;
- begin
- result := IndexOf(aItem);
- if (result >= 0) then
- DeleteIntern(result, true);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlCustomList.Create(aEqualityComparer: IEqualityComparer; const aOwnsItems: Boolean);
- begin
- if not Assigned(aEqualityComparer) then
- raise EArgumentNilException.Create('aEqualityComparer');
- inherited Create(aOwnsItems);
- fEqualityComparer := aEqualityComparer;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlCustomList.Destroy;
- begin
- fEqualityComparer := nil;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlList//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlList.Create(const aOwnsItems: Boolean);
- begin
- inherited Create(TEqualityComparer.Create, aOwnsItems);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlCustomHashSet/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomHashSet.SetCount(const aValue: Integer);
- begin
- raise ENotSupportedException.Create('SetCount not supported');
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomHashSet.SetItem(const aIndex: Integer; aValue: T);
- begin
- if not fComparer.EqualityCompare(GetItem(aIndex), aValue) then
- EInvalidOperation.Create('values are not equal');
- inherited SetItem(aIndex, aValue);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomHashSet.Add(constref aItem: T): Boolean;
- var
- i: Integer;
- begin
- result := not TBinarySearch.Search(self, fComparer, aItem, i);
- if result then
- InsertIntern(i, aItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomHashSet.Contains(constref aItem: T): Boolean;
- var
- i: Integer;
- begin
- result := TBinarySearch.Search(self, fComparer, aItem, i);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomHashSet.IndexOf(constref aItem: T): Integer;
- begin
- if not TBinarySearch.Search(self, fComparer, aItem, result) then
- result := -1;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomHashSet.Remove(constref aItem: T; const aFreeItem: Boolean): Boolean;
- var
- i: Integer;
- begin
- result := TBinarySearch.Search(self, fComparer, aItem, i);
- if result then
- DeleteIntern(i, aFreeItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomHashSet.Delete(const aIndex: Integer);
- begin
- DeleteIntern(aIndex, true);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlCustomHashSet.Create(aComparer: IComparer; const aOwnsItems: Boolean);
- begin
- inherited Create(aOwnsItems);
- fComparer := aComparer;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlCustomHashSet.Destroy;
- begin
- fComparer := nil;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlHastSet///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlHashSet.Create(const aOwnsItems: Boolean);
- begin
- inherited Create(TComparer.Create, aOwnsItems);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlCustomMap.THashSet////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomMap.THashSet.Release(var aItem: TKeyValuePair; const aFreeItem: Boolean);
- begin
- if not utlFinalizeObject(aItem.Key, TypeInfo(aItem.Key), fOwner.OwnsKeys and aFreeItem) then
- Finalize(aItem.Key);
- if not utlFinalizeObject(aItem.Value, TypeInfo(aItem.Value), fOwner.OwnsValues and aFreeItem) then
- Finalize(aItem.Key);
- inherited Release(aItem, aFreeItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlCustomMap.THashSet.Create(const aOwner: TutlCustomMap; aComparer: IComparer);
- begin
- inherited Create(aComparer, true);
- fOwner := aOwner;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlCustomMap.TKeyValuePairComparer///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TKeyValuePairComparer.EqualityCompare(constref i1, i2: TKeyValuePair): Boolean;
- begin
- result := fComparer.EqualityCompare(i1.Key, i2.Key);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TKeyValuePairComparer.Compare(constref i1, i2: TKeyValuePair): Integer;
- begin
- result := fComparer.Compare(i1.Key, i2.Key);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlCustomMap.TKeyValuePairComparer.Create(aComparer: IComparer);
- begin
- if not Assigned(aComparer) then
- raise EArgumentNilException.Create('aComparer');
- inherited Create;
- fComparer := aComparer;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlCustomMap.TKeyValuePairComparer.Destroy;
- begin
- fComparer := nil;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlCustomMap.TKeyEnumerator//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TKeyEnumerator.InternalMoveNext: Boolean;
- begin
- result := fEnumerator.MoveNext;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomMap.TKeyEnumerator.InternalReset;
- begin
- fEnumerator.Reset;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TKeyEnumerator.GetCurrent: TKey;
- begin
- result := fEnumerator.GetCurrent.Key;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlCustomMap.TKeyEnumerator.Create(aEnumerator: IutlKeyValuePairEnumerator);
- begin
- if not Assigned(aEnumerator) then
- raise EArgumentNilException.Create('aEnumerator');
- fEnumerator := aEnumerator;
- inherited Create;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlCustomMap.TValueEnumerator////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TValueEnumerator.InternalMoveNext: Boolean;
- begin
- result := fEnumerator.MoveNext;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomMap.TValueEnumerator.InternalReset;
- begin
- fEnumerator.Reset;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TValueEnumerator.GetCurrent: TValue;
- begin
- result := fEnumerator.GetCurrent.Value;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlCustomMap.TValueEnumerator.Create(aEnumerator: IutlKeyValuePairEnumerator);
- begin
- if not Assigned(aEnumerator) then
- raise EArgumentNilException.Create('aEnumerator');
- fEnumerator := aEnumerator;
- inherited Create;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlCustomMap.TKeyCollection//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TKeyCollection.GetEnumerator: IKeyEnumerator;
- begin
- result := TKeyEnumerator.Create(fHashSet.GetUtlEnumerator);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TKeyCollection.GetUtlEnumerator: IutlKeyEnumerator;
- begin
- result := TKeyEnumerator.Create(fHashSet.GetUtlEnumerator);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TKeyCollection.GetCount: Integer;
- begin
- result := fHashSet.Count;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TKeyCollection.GetItem(const aIndex: Integer): TKey;
- begin
- result := fHashSet[aIndex].Key;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlCustomMap.TKeyCollection.Create(const aHashSet: THashSet);
- begin
- inherited Create;
- fHashSet := aHashSet;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlCustomMap.TKeyValuePairCollection/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TKeyValuePairCollection.GetEnumerator: IKeyValuePairEnumerator;
- begin
- result := fHashSet.GetEnumerator;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TKeyValuePairCollection.GetUtlEnumerator: IutlKeyValuePairEnumerator;
- begin
- result := fHashSet.GetUtlEnumerator;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TKeyValuePairCollection.GetCount: Integer;
- begin
- result := fHashSet.Count;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TKeyValuePairCollection.GetItem(const aIndex: Integer): TKeyValuePair;
- begin
- result := fHashSet[aIndex];
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlCustomMap.TKeyValuePairCollection.Create(const aHashSet: THashSet);
- begin
- inherited Create;
- fHashSet := aHashSet;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlCustomMap/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.GetValue(aKey: TKey): TValue;
- var
- i: Integer;
- kvp: TKeyValuePair;
- begin
- kvp.Key := aKey;
- i := fHashSetRef.IndexOf(kvp);
- if (i < 0)
- then FillByte(result{%H-}, SizeOf(result), 0)
- else result := fHashSetRef[i].Value;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.GetValueAt(const aIndex: Integer): TValue;
- begin
- result := fHashSetRef[aIndex].Value;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.GetCount: Integer;
- begin
- result := fHashSetRef.Count;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.GetIsEmpty: Boolean;
- begin
- result := fHashSetRef.IsEmpty;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.GetCapacity: Integer;
- begin
- result := fHashSetRef.Capacity;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.GetCanShrink: Boolean;
- begin
- result := fHashSetRef.CanShrink;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.GetCanExpand: Boolean;
- begin
- result := fHashSetRef.CanExpand;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomMap.SetCapacity(const aValue: Integer);
- begin
- fHashSetRef.Capacity := aValue;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomMap.SetCanShrink(const aValue: Boolean);
- begin
- fHashSetRef.CanShrink := aValue;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomMap.SetCanExpand(const aValue: Boolean);
- begin
- fHashSetRef.CanExpand := aValue;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomMap.SetValue(aKey: TKey; const aValue: TValue);
- var
- i: Integer;
- kvp: TKeyValuePair;
- begin
- kvp.Key := aKey;
- kvp.Value := aValue;
- i := fHashSetRef.IndexOf(kvp);
- if (i < 0) then begin
- if not fAutoCreate then
- raise EInvalidOperation.Create('key not found');
- fHashSetRef.Add(kvp);
- end else
- fHashSetRef[i] := kvp;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomMap.SetValueAt(const aIndex: Integer; const aValue: TValue);
- var
- kvp: TKeyValuePair;
- begin
- kvp := fHashSetRef[aIndex];
- kvp.Value := aValue;
- fHashSetRef[aIndex] := kvp;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.GetEnumerator: IValueEnumerator;
- begin
- result := TValueEnumerator.Create(fHashSetRef.GetUtlEnumerator);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.GetUtlEnumerator: IutlValueEnumerator;
- begin
- result := TValueEnumerator.Create(fHashSetRef.GetUtlEnumerator);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomMap.Add(constref aKey: TKey; constref aValue: TValue);
- begin
- if not TryAdd(aKey, aValue) then
- raise EInvalidOperation.Create('key already exists');
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TryAdd(constref aKey: TKey; constref aValue: TValue): Boolean;
- var
- kvp: TKeyValuePair;
- begin
- kvp.Key := aKey;
- kvp.Value := aValue;
- result := fHashSetRef.Add(kvp);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TryGetValue(constref aKey: TKey; out aValue: TValue): Boolean;
- var
- i: Integer;
- begin
- i := IndexOf(aKey);
- result := (i >= 0);
- if result
- then aValue := fHashSetRef[i].Value
- else FillByte(result, SizeOf(result), 0);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.IndexOf(constref aKey: TKey): Integer;
- var
- kvp: TKeyValuePair;
- begin
- kvp.Key := aKey;
- result := fHashSetRef.IndexOf(kvp);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.Contains(constref aKey: TKey): Boolean;
- begin
- result := (IndexOf(aKey) >= 0);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.Remove(constref aKey: TKey; const aFreeItem: Boolean): Boolean;
- var
- kvp: TKeyValuePair;
- begin
- kvp.Key := aKey;
- result := fHashSetRef.Remove(kvp, aFreeItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomMap.Delete(constref aKey: TKey);
- begin
- if not Remove(aKey) then
- raise EInvalidOperation.Create('key not found');
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomMap.DeleteAt(const aIndex: Integer);
- begin
- fHashSetRef.Delete(aIndex);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomMap.Clear;
- begin
- fHashSetRef.Clear;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlCustomMap.Create(
- const aHashSet: THashSet;
- const aOwnsKeys: Boolean;
- const aOwnsValues: Boolean);
- begin
- if not Assigned(aHashSet) then
- EArgumentNilException.Create('aHashSet');
-
- inherited Create;
-
- fAutoCreate := false;
- fHashSetRef := aHashSet;
- fOwnsKeys := aOwnsKeys;
- fOwnsValues := aOwnsValues;
-
- fKeyCollection := TKeyCollection.Create(fHashSetRef);
- fKeyValuePairCollection := TKeyValuePairCollection.Create(fHashSetRef);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlCustomMap.Destroy;
- begin
- Clear;
- FreeAndNil(fKeyValuePairCollection);
- FreeAndNil(fKeyCollection);
- fHashSetRef := nil;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlMap///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlMap.Create(const aOwnsKeys: Boolean; const aOwnsValues: Boolean);
- begin
- fHashSetImpl := THashSet.Create(self, TKeyValuePairComparer.Create(TComparer.Create));
- inherited Create(fHashSetImpl, aOwnsKeys, aOwnsValues);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlMap.Destroy;
- begin
- inherited Destroy;
- FreeAndNil(fHashSetImpl);
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlHandleManager.TPriorityItem////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlHandleManager.TPriorityItem.GetHandleEntry(const aIndex: TIndex): PHandleEntry;
- begin
- if (aIndex > HighIndex(Handles)) then
- Grow;
- result := @Handles[aIndex];
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlHandleManager.TPriorityItem.Grow(const aSize: Integer);
- var
- oldIdx, newIdx, i: TIndex;
- begin
- oldIdx := Length(Handles);
- if (aSize = 0) then
- SetLength(Handles, Length(Handles) + GROW_SIZE)
- else if (Length(Handles) >= aSize) then
- exit
- else
- SetLength(Handles, aSize);
- newIdx := High(Handles);
- for i := oldIdx to newIdx do begin
- FillByte(Handles[i].Data, SizeOf(T), 0);
- Handles[i].Counter := 0;
- Handles[i].Status := ENTRY_STATUS_UNKNOWN;
- Handles[i].Next := High(TIndex);
- Handles[i].Prev := High(TIndex);
- PushBackFreeIndex(i);
- end;
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlHandleManager.TPriorityItem.PushFront(const aIndex: TIndex; var FirstIndex, LastIndex: TIndex;
- const aStatus: TEntryStatus);
- begin
- Assert(aIndex <= HighIndex(Handles));
- Assert(Handles[aIndex].Status = ENTRY_STATUS_UNKNOWN);
- if (FirstIndex <> UNKNOWN_INDEX)
- and (FirstIndex <= HighIndex(Handles))
- and (Handles[FirstIndex].Status = aStatus)
- then
- Handles[FirstIndex].Prev := aIndex;
- with Handles[aIndex] do begin
- Prev := UNKNOWN_INDEX;
- Next := FirstIndex;
- Status := aStatus;
- end;
- FirstIndex := aIndex;
- if (LastIndex = UNKNOWN_INDEX) then
- LastIndex := aIndex;
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlHandleManager.TPriorityItem.PushBack(const aIndex: TIndex; var FirstIndex, LastIndex: TIndex;
- const aStatus: TEntryStatus);
- begin
- Assert(aIndex <= HighIndex(Handles));
- Assert(Handles[aIndex].Status = ENTRY_STATUS_UNKNOWN);
- if (LastIndex <> UNKNOWN_INDEX)
- and (LastIndex <= HighIndex(Handles))
- and (Handles[LastIndex].Status = aStatus)
- then
- Handles[LastIndex].Next := aIndex;
- with Handles[aIndex] do begin
- Prev := LastIndex;
- Next := UNKNOWN_INDEX;
- Status := aStatus;
- end;
- LastIndex := aIndex;
- if (FirstIndex = UNKNOWN_INDEX) then
- FirstIndex := aIndex;
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlHandleManager.TPriorityItem.Remove(const aIndex: TIndex; var FirstIndex, LastIndex: TIndex; const aStatus: TEntryStatus);
- begin
- Assert(aIndex <> UNKNOWN_INDEX);
- Assert(aIndex <= HighIndex(Handles));
- Assert(Handles[aIndex].Status = aStatus);
- with Handles[aIndex] do begin
- if (Prev <> UNKNOWN_INDEX) then begin
- Assert(Prev <= HighIndex(Handles));
- Handles[Prev].Next := Next;
- end;
- if (Next <> UNKNOWN_INDEX) then begin
- Assert(Next <= HighIndex(Handles));
- Handles[Next].Prev := Prev;
- end;
- if (aIndex = FirstIndex) then
- FirstIndex := Next;
- if (aIndex = LastIndex) then
- LastIndex := Prev;
- Prev := UNKNOWN_INDEX;
- Next := UNKNOWN_INDEX;
- Status := ENTRY_STATUS_UNKNOWN;
- end;
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlHandleManager.TPriorityItem.PopFront(var FirstIndex, LastIndex: TIndex; const aStatus: TEntryStatus; const aCanGrow: Boolean): TIndex;
- begin
- if aCanGrow
- and ( (FirstIndex = UNKNOWN_INDEX)
- or (FirstIndex > HighIndex(Handles)))
- then
- Grow;
- Assert(FirstIndex <> UNKNOWN_INDEX);
- Assert(FirstIndex <= HighIndex(Handles));
- Assert(Handles[FirstIndex].Status = aStatus);
- result := FirstIndex;
- with Handles[result] do begin
- if (LastIndex = FirstIndex) then
- LastIndex := Next;
- FirstIndex := Next;
- Prev := UNKNOWN_INDEX;
- Next := UNKNOWN_INDEX;
- Status := ENTRY_STATUS_UNKNOWN;
- end;
- if (FirstIndex <> UNKNOWN_INDEX)
- and (FirstIndex <= HighIndex(Handles))
- and (Handles[FirstIndex].Status = aStatus)
- then
- Handles[FirstIndex].Prev := UNKNOWN_INDEX;
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlHandleManager.TPriorityItem.PopBack(var FirstIndex, LastIndex: TIndex; const aStatus: TEntryStatus; const aCanGrow: Boolean): TIndex;
- begin
- if aCanGrow
- and ( (LastIndex <> UNKNOWN_INDEX)
- or (LastIndex <= HighIndex(Handles)))
- then
- Grow;
- Assert(LastIndex <> UNKNOWN_INDEX);
- Assert(LastIndex <= HighIndex(Handles));
- Assert(Handles[LastIndex].Status = aStatus);
- result := LastIndex;
- with Handles[result] do begin
- if (FirstIndex = LastIndex) then
- FirstIndex := Next;
- LastIndex := Prev;
- Prev := UNKNOWN_INDEX;
- Next := UNKNOWN_INDEX;
- Status := ENTRY_STATUS_UNKNOWN;
- end;
- if (LastIndex <> UNKNOWN_INDEX)
- and (LastIndex <= HighIndex(Handles))
- and (Handles[LastIndex].Status = aStatus)
- then
- Handles[LastIndex].Next := UNKNOWN_INDEX;
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlHandleManager.TPriorityItem.PushFrontFreeIndex(const aIndex: TIndex);
- begin
- PushFront(aIndex, FirstFree, LastFree, ENTRY_STATUS_FREE);
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlHandleManager.TPriorityItem.PushBackFreeIndex(const aIndex: TIndex);
- begin
- PushBack(aIndex, FirstFree, LastFree, ENTRY_STATUS_FREE);
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlHandleManager.TPriorityItem.PushFrontUsedIndex(const aIndex: TIndex);
- begin
- PushFront(aIndex, FirstUsed, LastUsed, ENTRY_STATUS_USED);
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlHandleManager.TPriorityItem.PushBackUsedIndex(const aIndex: TIndex);
- begin
- PushBack(aIndex, FirstUsed, LastUsed, ENTRY_STATUS_USED);
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlHandleManager.TPriorityItem.RemoveFreeIndex(const aIndex: TIndex);
- begin
- Remove(aIndex, FirstFree, LastFree, ENTRY_STATUS_FREE);
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlHandleManager.TPriorityItem.RemoveUsedIndex(const aIndex: TIndex);
- begin
- Remove(aIndex, FirstUsed, LastUsed, ENTRY_STATUS_USED);
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlHandleManager.TPriorityItem.PopFrontFreeIndex: TIndex;
- begin
- result := PopFront(FirstFree, LastFree, ENTRY_STATUS_FREE, true);
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlHandleManager.TPriorityItem.PopBackFreeIndex: TIndex;
- begin
- result := PopBack(FirstFree, LastFree, ENTRY_STATUS_FREE, false);
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlHandleManager.TPriorityItem.PopFrontUsedIndex: TIndex;
- begin
- result := PopFront(FirstUsed, LastUsed, ENTRY_STATUS_USED, false);
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlHandleManager.TPriorityItem.PopBackUsedIndex: TIndex;
- begin
- result := PopBack(FirstUsed, LastUsed, ENTRY_STATUS_USED, false);
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlHandleManager.TEnumerator//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlHandleManager.TEnumerator.InternalMoveNext: Boolean;
- var
- p: PPriorityItem;
- begin
- repeat
- if (fIndex = UNKNOWN_INDEX) then begin
- inc(fPriority);
- if (fPriority > High(fOwner.fItems)) then
- break;
- p := fOwner.GetPriorityItem(fPriority);
- fIndex := p^.FirstUsed;
- end else begin
- p := fOwner.GetPriorityItem(fPriority);
- fIndex := p^.Handles[fIndex].Next;
- if (fIndex > HighIndex(p^.Handles)) then
- fIndex := UNKNOWN_INDEX;
- end;
- until (fPriority > High(fOwner.fItems)) or (fIndex <> UNKNOWN_INDEX);
- result := (fPriority <= High(fOwner.fItems));
- if result then begin
- p := fOwner.GetPriorityItem(fPriority);
- fHandle := p^.Handles[fIndex];
- end else
- FillByte(fHandle, SizeOf(fHandle), 0);
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlHandleManager.TEnumerator.InternalReset;
- begin
- fPriority := -1;
- fIndex := UNKNOWN_INDEX;
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlHandleManager.TEnumerator.GetCurrent: TutlHandle;
- begin
- if (fHandle.Status <> ENTRY_STATUS_USED) then
- raise EInvalidOperation.Create('enumerator not initialized or collection changed');
- with THandleData(result) do begin
- Index := fIndex;
- Counter := fHandle.Counter;
- TypeID := fHandle.TypeID;
- Priority := fPriority;
- end;
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlHandleManager.TEnumerator.Create(const aOwner: TutlHandleManager);
- begin
- if not Assigned(aOwner) then
- raise EArgumentNilException.Create('aOwner');
- inherited Create;
- fOwner := aOwner;
- FillByte(fHandle, SizeOf(fHandle), 0);
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlHandleManager Class Methods////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlHandleManager.HighIndex(constref aEntries: THandleEntries): TIndex;
- begin
- result := TIndex(High(aEntries));
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlHandleManager//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlHandleManager.GetPriorityItem(const aPriority: Byte): PPriorityItem;
- var
- oldIdx, newIdx, i: Integer;
- begin
- if (aPriority > High(fItems)) then begin
- oldIdx := Length(fItems);
- SetLength(fItems, aPriority + 1);
- newIdx := High(fItems);
- for i := oldIdx to newIdx do with fItems[i] do begin
- FirstFree := UNKNOWN_INDEX;
- LastFree := UNKNOWN_INDEX;
- FirstUsed := UNKNOWN_INDEX;
- LastUsed := UNKNOWN_INDEX;
- SetLength(Handles, 0);
- end;
- end;
- result := @fItems[aPriority];
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlHandleManager.GetValue(const aHandle: TutlHandle): T;
- begin
- if not TryGetValue(aHandle, result) then
- raise EArgumentException.Create('unknown or invalid handle');
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlHandleManager.TryGetValue(const aHandle: TutlHandle; out aData: T): Boolean;
- begin
- result := IsValid(aHandle);
- with THandleData(aHandle) do begin
- if result
- then aData := fItems[Priority].Handles[Index].Data
- else FillByte(aData, SizeOf(T), 0);
- end;
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlHandleManager.SetValue(const aHandle: TutlHandle; aData: T);
- begin
- if not TrySetValue(aHandle, aData) then
- raise EArgumentException.Create('unknown or invalid handle');
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlHandleManager.TrySetValue(const aHandle: TutlHandle; aData: T): Boolean;
- var
- p: PPriorityItem;
- h: PHandleEntry;
- begin
- if not IsValid(aHandle) then with THandleData(aHandle) do begin
- p := GetPriorityItem(Priority);
- p^.Grow(Index + 1);
- h := p^.GetHandleEntry(Index);
- result := (h^.Status = ENTRY_STATUS_FREE);
- if result then begin
- p^.RemoveFreeIndex (Index);
- p^.PushBackUsedIndex(Index);
- h^.Counter := Counter;
- h^.Data := aData;
- h^.TypeID := TypeID;
- end;
- end else
- Update(aHandle, aData);
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlHandleManager.Add(const aTypeID: Byte; const aPriority: Byte; constref aData: T): TutlHandle;
- var
- p: PPriorityItem;
- h: PHandleEntry;
- i: Integer;
- begin
- p := GetPriorityItem(aPriority);
- i := p^.PopFrontFreeIndex;
- p^.PushBackUsedIndex(i);
- h := p^.GetHandleEntry(i);
- h^.TypeID := aTypeID;
- h^.Counter := h^.Counter + 1;
- if (h^.Counter = 0) then
- h^.Counter := 1;
- h^.Data := aData;
- with THandleData(result) do begin
- Index := i;
- Counter := h^.Counter;
- TypeID := aTypeID;
- Priority := aPriority;
- end;
- inc(fCount);
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlHandleManager.IsValid(const aHandle: TutlHandle): Boolean;
- begin
- with THandleData(aHandle) do begin
- result := (Priority <= High(fItems))
- and (Index <= HighIndex(fItems[Priority].Handles))
- and (fItems[Priority].Handles[Index].Counter = Counter)
- and (fItems[Priority].Handles[Index].Status = ENTRY_STATUS_USED);
- end;
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlHandleManager.Update(const aHandle: TutlHandle; aData: T);
- begin
- if not IsValid(aHandle) then
- raise EArgumentException.Create('unknown or invalid handle');
- with THandleData(aHandle) do begin
- if not utlFinalizeObject(fItems[Priority].Handles[Index].Data, TypeInfo(T), fOwnsValues) then
- Finalize(fItems[Priority].Handles[Index].Data);
- fItems[Priority].Handles[Index].Data := aData;
- end;
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlHandleManager.Remove(const aHandle: TutlHandle): Boolean;
- var
- p: PPriorityItem;
- begin
- result := IsValid(aHandle);
- if not result then
- exit;
- with THandleData(aHandle) do begin
- p := GetPriorityItem(Priority);
- p^.RemoveUsedIndex(Index);
- p^.PushFrontFreeIndex(Index);
- end;
- dec(fCount);
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlHandleManager.Delete(const aHandle: TutlHandle);
- begin
- if not Remove(aHandle) then
- raise EArgumentException.Create('unknown or invalid handle');
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlHandleManager.Clear;
- var
- i, j: Integer;
- begin
- for j := low(fItems) to high(fItems) do begin
- for i := low(fItems[j].Handles) to high(fItems[j].Handles) do begin
- if (fItems[j].Handles[i].Status = ENTRY_STATUS_USED) and not utlFinalizeObject(fItems[j].Handles[i].Data, TypeInfo(T), fOwnsValues) then
- Finalize(fItems[j].Handles[i].Data);
- FillByte(fItems[j].Handles[i].Data, SizeOf(T), 0);
- end;
- SetLength(fItems[j].Handles, 0);
- end;
- SetLength(fItems, 0);
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlHandleManager.GetEnumerator: IEnumerator;
- begin
- result := TEnumerator.Create(self);
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlHandleManager.GetUtlEnumerator: IutlEnumerator;
- begin
- result := TEnumerator.Create(self);
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlHandleManager.Create(const aOwnsValues: Boolean);
- begin
- inherited Create;
- fCount := 0;
- fOwnsValues := aOwnsValues;
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlHandleManager.Destroy;
- begin
- // Clear;
- inherited Destroy;
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlHandleManager.GetTypeID(const aHandle: TutlHandle): Byte;
- begin
- result := THandleData(aHandle).TypeID;
- end;
-
- /////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlHandleManager.GetPriority(const aHandle: TutlHandle): Byte;
- begin
- result := THandleData(aHandle).Priority;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //EutlEnumConvert///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor EEnumConvertException.Create(const aValue, aExpectedType: String);
- begin
- inherited Create(Format('%s is not a %s', [aValue, aExpectedType]));
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlEnumHelperBase////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class procedure TutlEnumHelperBase.RegisterType(const aValues: TIntArray; const aNames: TStringArray);
- begin
- fValuesMap.Add(ClassName, aValues);
- fNamesMap.Add (ClassName, aNames);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class procedure TutlEnumHelperBase.UnregisterType;
- begin
- fValuesMap.Remove(ClassName);
- fNamesMap.Remove(ClassName);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlEnumHelperBase.ToString(const aValue: Integer; const aAllowOrd: Boolean = false): String;
- var
- i: Integer;
- iArr: TIntArray;
- sArr: TStringArray;
- begin
- iArr := fValuesMap[ClassName];
- sArr := fNamesMap[ClassName];
- for i := low(iArr) to high(iArr) do begin
- if (iArr[i] = aValue) then begin
- result := sArr[i];
- exit;
- end;
- end;
- if aAllowOrd
- then result := IntToStr(aValue)
- else result := '';
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlEnumHelperBase.TryToEnum(const aStr: String; out aValue: Integer; const aAllowOrd: Boolean = false): Boolean;
- var
- i: Integer;
- iArr: TIntArray;
- sArr: TStringArray;
- begin
- iArr := fValuesMap[ClassName];
- sArr := fNamesMap[ClassName];
- for i := low(sArr) to high(sArr) do begin
- if (sArr[i] = aStr) then begin
- result := true;
- aValue := iArr[i];
- exit;
- end;
- end;
- if aAllowOrd
- then result := TryStrToInt(aStr, aValue)
- else result := false;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlEnumHelperBase.ToEnum(const aStr: String; const aAllowOrd: Boolean): Integer;
- begin
- if not TryToEnum(aStr, result, aAllowOrd) then
- raise EConvertError.Create(aStr + ' is an unknown enum value');
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlEnumHelperBase.ToEnum(const aStr: String; const aDefault: Integer; const aAllowOrd: Boolean): Integer;
- begin
- if not TryToEnum(aStr, result, aAllowOrd) then
- result := aDefault;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlEnumHelperBase.IntValues: TIntArray;
- begin
- result := fValuesMap[ClassName];
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlEnumHelperBase.Names: TStringArray;
- begin
- result := fNamesMap[ClassName];
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class constructor TutlEnumHelperBase.Initialize;
- begin
- fNamesMap := TNamesMap.Create(true, true);
- fValuesMap := TValuesMap.Create(true, true);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class destructor TutlEnumHelperBase.Finalize;
- begin
- FreeAndNil(fNamesMap);
- FreeAndNil(fValuesMap);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlEnumHelper////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlEnumHelper.ToString(const aValue: T; const aAllowOrd: Boolean): String;
- begin
- {$Push}
- {$IOChecks OFF}
- WriteStr(Result, aValue);
- if IOResult = 107 then
- Result := '';
- {$Pop}
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlEnumHelper.TryToEnum(const aStr: String; out aValue: T; const aAllowOrd: Boolean): Boolean;
- var
- a: T;
- i: Integer;
- begin
- a := T(0);
- Result := false;
- if Length(aStr) = 0 then
- exit;
-
- {$Push}
- {$IOChecks OFF}
- ReadStr(aStr, a);
- Result := IOResult <> 106;
- {$Pop}
- if Result then
- aValue := a
- else if aAllowOrd then begin
- result := TryStrToInt(aStr, i);
- if result then
- aValue := T(i);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlEnumHelper.ToEnum(const aStr: String; const aAllowOrd: Boolean): T;
- begin
- if not TryToEnum(aStr, result, aAllowOrd) then
- raise EEnumConvertException.Create(aStr, TypeInfo^.Name);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlEnumHelper.ToEnum(const aStr: String; const aDefault: T; const aAllowOrd: Boolean): T;
- begin
- if not TryToEnum(aStr, result, aAllowOrd) then
- result := aDefault;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlEnumHelper.Values: TValueArray;
- begin
- result := fValues;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlEnumHelper.IntValues: TIntArray;
- begin
- result := fIntValues;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlEnumHelper.Names: TStringArray;
- begin
- result := fNames;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlEnumHelper.TypeInfo: PTypeInfo;
- begin
- result := fTypeInfo;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class constructor TutlEnumHelper.Initialize;
- var
- tiArray: PTypeInfo;
- tdArray, tdEnum: PTypeData;
- PName: PShortString;
- i: integer;
- en: T;
- sl: TStringList;
- begin
- {
- See FPC Bug http://bugs.freepascal.org/view.php?id=27622
- For Sparse Enums, the compiler won't give us TypeInfo, because it contains some wrong data. This is
- safe, but sadly we don't even get the *correct* fields (TypeName, NameList), even though they are
- generated in any case.
- Fortunately, arrays do know this type info segment as their Element Type (and we declared one anyway).
- }
- tiArray := System.TypeInfo(TValueArray);
- tdArray := GetTypeData(tiArray);
- fTypeInfo := tdArray^.elType2;
-
- {
- Now that we have the TypeInfo, fill our values from it. This is safe because while the *values* in
- TypeData are wrong for Sparse Enums, the *PName* are always correct.
- }
- tdEnum := GetTypeData(FTypeInfo);
- PName := @tdEnum^.NameList;
- sl := TStringList.Create;
- try
- while Length(PName^) > 0 do begin
- {
- Memory layout for TTypeData has the declaring EnumUnitName after the last NameList entry.
- This can normally not be the same as a valid enum value, because it is in the same identifier
- namespace. However, with scoped enums we might have the same name for module and element, because
- the full identifier for the element would be TypeName.ElementName.
- In either case, the next PShortString will point to a zero-length string, and the loop is left
- with the last element being invalid (either empty or whatever value the unit-named element has).
- }
- sl.Add(PName^);
- if TryToEnum(PName^, en) then
- sl.Objects[sl.Count-1] := TObject({%H-}Pointer(PtrUInt(en)));
- inc(PByte(PName), Length(PName^) + 1);
- end;
-
- sl.Delete(sl.Count-1); // remove the EnumUnitName item
- SetLength(fValues, sl.Count);
- SetLength(fIntValues, sl.Count);
- SetLength(fNames, sl.Count);
- for i := 0 to sl.Count-1 do begin
- fNames[i] := sl[i];
- fValues[i] := T(PtrUInt(sl.Objects[i]));
- fIntValues[i] := Integer(fValues[i]);
- end;
-
- finally
- FreeAndNil(sl);
- end;
-
- RegisterType(fIntValues, fNames);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class destructor TutlEnumHelper.Finalize;
- begin
- Finalize(fNames);
- Finalize(fValues);
- Finalize(fIntValues);
- UnregisterType;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlSetHelperBase/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlSetHelperBase.IsSet(const aSet; const aSize: Integer; const aValue: Integer): Boolean;
- begin
- if (aValue >= 8*aSize) then
- raise EOutOfRangeException.Create(aValue, 0, 8*aSize-1);
- result := ((PByte(@aSet)[aValue shr 3] and (1 shl (aValue and 7))) <> 0);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class procedure TutlSetHelperBase.SetValue(var aSet; const aSize: Integer; const aValue: Integer);
- begin
- if (aValue >= 8*aSize) then
- raise EOutOfRangeException.Create(aValue, 0, 8*aSize-1);
- PByte(@aSet)[aValue shr 3] := PByte(@aSet)[aValue shr 3] or (1 shl (aValue and 7));
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class procedure TutlSetHelperBase.ClearValue(var aSet; const aSize: Integer; const aValue: Integer);
- begin
- if (aValue >= 8*aSize) then
- raise EOutOfRangeException.Create(aValue, 0, 8*aSize-1);
- PByte(@aSet)[aValue shr 3] := PByte(@aSet)[aValue shr 3] and not (1 shl (aValue and 7));
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class procedure TutlSetHelperBase.RegisterEnumHelper(const aHelper: TutlEnumHelperBaseClass);
- begin
- fEnumHelpers.Add(ClassName, aHelper);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class procedure TutlSetHelperBase.UnregisterEnumHelper;
- begin
- fEnumHelpers.Remove(ClassName);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlSetHelperBase.ToString(const aSet; const aSize: Integer; const aSeparator: String;
- const aAllowOrd: Boolean): String;
- var
- i: Integer;
- h: TutlEnumHelperBaseClass;
- arr: TutlEnumHelperBase.TIntArray;
- begin
- h := EnumHelper;
- if not Assigned(h) then
- raise EInvalidOperation.Create('enum helper class is not set');
- result := '';
- arr := h.IntValues;
- for i in arr do begin
- if IsSet(aSet, aSize, i) then begin
- if result > '' then
- result := result + aSeparator;
- result := result + h.ToString(i, aAllowOrd);
- end;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlSetHelperBase.TryToSet(const aStr: String; out aSet; const aSize: Integer; const aAllowOrd: Boolean): Boolean;
- begin
- result := TryToSet(aStr, ',', aSet, aSize, aAllowOrd);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlSetHelperBase.TryToSet(const aStr: String; const aSeparator: String; out aSet; const aSize: Integer; const aAllowOrd: Boolean): Boolean;
- var
- i, j, e: Integer;
- s: String;
- h: TutlEnumHelperBaseClass;
- begin
- if (aSeparator = '') then
- raise EArgumentException.Create('''aSeparator'' can not be empty');
- h := EnumHelper;
- if not Assigned(h) then
- raise EInvalidOperation.Create('enum helper class is not set');
-
- result := true;
- i := 1;
- j := 1;
-
- FillByte(aSet{%H-}, aSize, 0);
- while (i <= Length(aStr)) do begin
- if (Copy(aStr, i, Length(aSeparator)) = aSeparator) then begin
- s := Trim(copy(aStr, j, i - j));
- if (s <> '') then begin
- result := result and h.TryToEnum(s, e);
- if not result then
- exit;
- SetValue(aSet, aSize, e);
- j := i + Length(aSeparator);
- end;
- end;
- inc(i);
- end;
-
- s := Trim(copy(aStr, j, i - j));
- if (s <> '') then begin
- result := result and h.TryToEnum(s, e);
- if not result then
- exit;
- SetValue(aSet, aSize, e);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlSetHelperBase.Compare(const aSet1; const aSet2; const aSize: Integer): Integer;
- var
- e: Integer;
- h: TutlEnumHelperBaseClass;
- begin
- h := EnumHelper;
- if not Assigned(h) then
- raise EInvalidOperation.Create('enum helper class is not set');
-
- result := 0;
- for e in h.IntValues do begin
- if IsSet(aSet1, aSize, e) and not IsSet(aSet2, aSize, e) then begin
- result := 1;
- break;
- end else
- if not IsSet(aSet1, aSize, e) and IsSet(aSet2, aSize, e) then begin
- result := -1;
- break;
- end;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlSetHelperBase.EnumHelper: TutlEnumHelperBaseClass;
- begin
- result := fEnumHelpers[ClassName];
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class constructor TutlSetHelperBase.Initialize;
- begin
- fEnumHelpers := TEnumHelperMap.Create(true, true);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class destructor TutlSetHelperBase.Finalize;
- begin
- FreeAndNil(fEnumHelpers);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlSetHelper/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlSetHelper.ToString(const aValue: TSet; const aSeparator: String; const aAllowOrd: Boolean): String;
- begin
- result := ToString(aValue, SizeOf(aValue), aSeparator, aAllowOrd);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlSetHelper.TryToSet(const aStr: String; out aValue: TSet; const aAllowOrd: Boolean): Boolean;
- begin
- result := TryToSet(aStr, ',', aValue, SizeOf(aValue), aAllowOrd);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlSetHelper.TryToSet(const aStr: String; const aSeparator: String; out aValue: TSet; const aAllowOrd: Boolean): Boolean;
- begin
- result := TryToSet(aStr, aSeparator, aValue, SizeOf(aValue), aAllowOrd);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlSetHelper.ToSet(const aStr: String; const aDefault: TSet; const aAllowOrd: Boolean): TSet;
- begin
- if not TryToSet(aStr, ',', result, SizeOf(result), aAllowOrd) then
- result := aDefault;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlSetHelper.ToSet(const aStr: String; const aAllowOrd: Boolean): TSet;
- begin
- if not TryToSet(aStr, ',', result, SizeOf(result), aAllowOrd) then
- raise EEnumConvertException.CreateFmt('"%s" is an invalid value', [aStr]);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlSetHelper.Compare(const aSet1, aSet2: TSet): Integer;
- begin
- result := Compare(aSet1, aSet2, SizeOf(aSet1));
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class constructor TutlSetHelper.Initialize;
- begin
- RegisterEnumHelper(TEnumHelper);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class destructor TutlSetHelper.Finalize;
- begin
- UnregisterEnumHelper();
- end;
-
- end.
|