unit tb0664; {$mode delphi} interface uses Generics.Defaults, Generics.Collections, SysUtils; type TuList = class {$IFDEF FPC} type TArrayT = Array of T; {$ENDIF} private function GetCapacity: integer; procedure SetCapacity(const Value: integer); protected {$IFDEF FPC} FData: TArrayT; {$ELSE} FData: TArray; {$ENDIF} FCount : integer; function GetItem(Index: Integer): T; procedure SetItem(Index: Integer; const Value: T); public constructor Create; overload; constructor Create(const aCapacity: integer); overload; function Add(const item: T): integer; property Count: integer read FCount; property Items[Index: Integer]: T read GetItem write SetItem; default; procedure Clear; virtual; {$IFDEF FPC} function ToArray: TArrayT; {$ELSE} function ToArray: TArray; {$ENDIF} procedure TrimExcess; property Capacity: integer read GetCapacity write SetCapacity; end; ListHelper = record public class procedure Reverse(const List: TuList); static; class function ToArray(const List: TuList): TArray; static; class procedure Sort(const List: TuList); overload; static; class procedure Sort(const List: TuList; AComparer: IComparer); overload; static; class procedure StableSort(const List: TuList; AComparer: IComparer); overload; static; class function BinarySearch(const List: TuList; const Item: T): Integer; overload; static; class function BinarySearch(const List: TuList; const Item: T; AComparer: IComparer): SizeInt; overload; static; class procedure Insert(const List: TuList; const index: integer; const Item: T); static; class procedure Delete(const List: TuList; const index: integer); static; class procedure InsertRange(const List: TuList; const index: integer; const Items: TArray); static; class procedure DeleteRange(const List: TuList; const index: integer; const dCount: integer); static; class procedure Remove(const List: TuList; const obj: T; AComparer: IComparer); static; class procedure AddManyInts(const List: TuList; const obj: UInt32; const aCount: Int32); static; class procedure AddArrayByte(const List: TuList; const Source: TArray; const aCount: Int32); static; end; TuObjectList = class(TuList) private FDontFree: Boolean; public constructor Create(const aCapacity: integer; const OwnsObjects: boolean); destructor Destroy; override; procedure Clear; override; procedure Insert(Index: Integer; const Value: TObject); procedure Delete(Index: Integer); procedure DeleteAndNotFree(Index: Integer); procedure RemoveRange(Index, Count: Integer); procedure SetCount(const a: integer); function IndexOfPointer(const Value: TObject): Integer; procedure RemovePointer(const obj: TObject); procedure SetButDontDestroy(const i: integer; const r: TObject); property DontFree: Boolean read FDontFree write FDontFree; end; {TuVListEnumerator = class(TEnumerator) private FList: TObject; //silly generics don't allow forward decl Position: integer; protected function DoGetCurrent: T; override; function DoMoveNext: Boolean; override; public constructor Create(const aList: TObject); end;} TuVList = class(TuObjectList) protected function GetItemTyped(Index: Integer): T; procedure SetItemTyped(Index: Integer; const Value: T); protected FComparer: IComparer; public constructor Create(const aCapacity: integer; const OwnsObjects: boolean); overload; constructor Create(const aComparer: IComparer); overload; property ItemTyped[Index: Integer]: T read GetItemTyped write SetItemTyped; default; //function GetEnumerator: TEnumerator; function ToArray: TArray; procedure Sort; overload; procedure Sort(aComparer: IComparer); overload; procedure StableSort(aComparer: IComparer); function BinarySearch(const Item: T): Integer; overload; function BinarySearch(const Item: T; aComparer: IComparer): Integer; overload; end; {$ifdef blubb} TuStack = class private FData: TArray; FCount: integer; public procedure Push(const v: T); function Pop: T; function Peek: T; function Count: integer; procedure Clear; end; TuOStack = class private FData: TArray; FCount: integer; public procedure Push(const v: T); procedure Pop; function Peek: T; function Count: integer; procedure Clear; end; { //can't create an instance in XE6 android TKeyComparer = class(TInterfacedObject, IComparer>) function Compare(const Left, Right: TPair): Integer; end; } TuSortedList = class type TPairKV = TPair; private List: TuList; function GetItems(const key: K): V; procedure SetItems(const key: K; const value: V); protected FComparer: IComparer; public constructor Create; overload; constructor Create(const aComparer: IComparer); overload; destructor Destroy; override; procedure Add(const key: K; const value: V); procedure Remove(const key: K); function ContainsKey(const key: K): boolean; function IndexOfKey(const key: K): integer; function TryGetValue(const key: K; out value: V): boolean; property Items[const key: K]: V read GetItems write SetItems; default; function Count: integer; function Values(const index: integer): V; function Keys(const index: integer): K; end; {$endif} procedure TrueFree(const obj: TObject); inline; procedure FreeObj(var obj); inline; procedure RaiseArgEx; function GetNextCapacity(const c: integer): integer; implementation //uses b; procedure TrueFree(const obj: TObject); begin {$ifdef AUTOREFCOUNT} begin obj.DisposeOf; end; {$else} begin obj.Free; end; {$endif} end; procedure FreeObj(var obj); {$ifdef AUTOREFCOUNT} begin if (Pointer(obj) <> nil) then TObject(obj).DisposeOf; TObject(obj) := nil; end; {$else} var Temp: TObject; begin Temp := TObject(Obj); Pointer(Obj) := nil; Temp.Free; end; {$endif} procedure RaiseArgEx; begin raise EArgumentOutOfRangeException.Create('Index out of bounds'); end; function GetNextCapacity(const c: integer): integer; begin if (c = 0) then exit(4); if c < 1000 then exit (c * 2); exit(c + 1000); end; {$RANGECHECKS OFF} procedure FillDWord(var Dest; Count, Value: UInt32); {$IFDEF CPUX86} asm XCHG EDX, ECX PUSH EDI MOV EDI, EAX MOV EAX, EDX REP STOSD POP EDI end; {$ELSE} type IntArray = array[0..0] of integer; PIntArray = ^IntArray; var i: integer; Arr: PIntArray; begin Arr := PIntArray(@Dest); for i := 0 to Count - 1 do Arr[i] := Value; end; {$ENDIF CPUX86} { TuList } constructor TuList.Create; begin inherited Create; end; constructor TuList.Create(const aCapacity: integer); begin inherited Create; Capacity := aCapacity; end; {$RANGECHECKS OFF} function TuList.Add(const item: T): integer; begin if FCount >= Length(FData) then begin SetLength(FData, GetNextCapacity(FCount)); end; FData[FCount] := item; Result := FCount; inc(FCount); end; procedure TuList.Clear; begin FData := nil; FCount := 0; end; function TuList.GetItem(Index: Integer): T; begin {$R-} if (Index >= Count) or (Index < 0)then RaiseArgEx; Result := FData[Index]; {$R+} end; procedure TuList.SetItem(Index: Integer; const Value: T); begin {$R-} if (Index >= Count) or (Index < 0)then RaiseArgEx; FData[Index] := Value; {$R+} end; {$IFDEF FPC} function TuList.ToArray: TArrayT; {$ELSE} function TuList.ToArray: TArray; {$ENDIF} begin SetLength(FData, FCount); Result := FData; //we won't return a deep copy. end; procedure TuList.TrimExcess; begin SetLength(FData, FCount); end; function TuList.GetCapacity: integer; begin Result := Length(FData); end; procedure TuList.SetCapacity(const Value: integer); begin if Value > FCount then SetLength(FData, value) else SetLength(FData, FCount); end; { TuVList } function TuVList.BinarySearch(const Item: T): Integer; begin Result := ListHelper.BinarySearch(TuList(self), Item, FComparer); end; function TuVList.BinarySearch(const Item: T; aComparer: IComparer): Integer; begin Result := ListHelper.BinarySearch(TuList(self), Item, aComparer); end; constructor TuVList.Create(const aCapacity: integer; const OwnsObjects: boolean); var Tmp: T; begin inherited Create(aCapacity, OwnsObjects); // Tmp := Default(T); // if Supports(TObject(Tmp), IComparable) then FComparer := TComparableComparer.Create(); end; constructor TuVList.Create(const aComparer: IComparer); begin inherited Create(4, true); FComparer := aComparer; end; {function TuVList.GetEnumerator: TEnumerator; begin Result := TuVListEnumerator.Create(self); end;} function TuVList.GetItemTyped(Index: Integer): T; begin {$R-} if (Index >= Count) or (Index < 0)then RaiseArgEx; Result := T(FData[Index]); {$R+} end; procedure TuVList.SetItemTyped(Index: Integer; const Value: T); begin {$R-} if (Index >= Count) or (Index < 0)then RaiseArgEx; if not DontFree then TrueFree(FData[Index]); FData[Index] := Value; {$R+} end; procedure TuVList.Sort(aComparer: IComparer); begin ListHelper.Sort(TuList(self), aComparer); end; procedure TuVList.StableSort(aComparer: IComparer); var CastData: TArray; begin TrimExcess; CastData := TArray(FData); // MergeSort.Sort(CastData, aComparer); end; procedure TuVList.Sort; begin ListHelper.Sort(TuList(self), FComparer); end; function TuVList.ToArray: TArray; var i: integer; begin Result := nil; SetLength(Result, FCount); for i := 0 to FCount - 1 do Result[i] := T(FData[i]); end; { ListHelper } class function ListHelper.BinarySearch(const List: TuList; const Item: T): Integer; begin Result := BinarySearch(List, Item, TComparer.Default); end; class function ListHelper.BinarySearch(const List: TuList; const Item: T; AComparer: IComparer): SizeInt; var b: boolean; begin if AComparer = nil then AComparer := TComparer.Default; b := {$IFDEF FPC}TArrayHelper.BinarySearch{$ELSE}TArray.BinarySearch{$ENDIF}(List.FData, Item, Result, AComparer, 0, List.Count); if not b then Result := not Result; end; class procedure ListHelper.Delete(const List: TuList; const index: integer); begin if (index > List.Count) or (index < 0) then RaiseArgEx; {$IFDEF FPC} List[index] := Default(T); //clear strings or interfaces. {$ELSE} {$if (CompilerVersion = 33.0) and (Defined(MACOS32) or Defined(IOS))} //see https://quality.embarcadero.com/browse/RSB-2792 We don't do it for the future since it should be fixed after RIO (and likely in a RIO ServicePack.) Finalize(List.FData[Index]); {$else} List[index] := Default(T); //clear strings or interfaces. {$ifend} {$ENDIF} if index + 1 < List.Count then begin Move(List.FData[index + 1], List.FData[index], SizeOf(T) * (List.Count - (index + 1))); FillChar(List.FData[List.FCount - 1], SizeOf(T), 0); //avoid having those records finalized end; dec(List.FCount); end; class procedure ListHelper.DeleteRange(const List: TuList; const index, dCount: integer); var i: integer; remaining, ToClean: integer; begin if dCount = 0 then exit; if (index > List.Count) or (index < 0) or (dCount < 0) or (dCount + index > List.Count) then RaiseArgEx; for i := 0 to dCount - 1 do List[index + i] := Default(T); //clear strings or interfaces. if index + dCount < List.Count then begin remaining := List.Count - (index + dcount); Move(List.FData[index + dCount], List.FData[index], SizeOf(T) * remaining); ToClean := remaining; if ToClean > dCount then ToClean := dCount; FillChar(List.FData[List.FCount - ToClean], ToClean * SizeOf(T), 0); //avoid having those records finalized end; dec(List.FCount, dCount); end; class procedure ListHelper.Insert(const List: TuList; const index: integer; const Item: T); begin if (index > List.Count) or (index < 0) then RaiseArgEx; if List.Count >= Length(List.FData) then begin SetLength(List.FData, GetNextCapacity(List.FCount)); end; if index < List.Count then begin Move(List.FData[index], List.FData[index + 1], SizeOf(T) * (List.Count - index)); FillChar(List.FData[index], SizeOf(T), 0); //avoid having those records finalized end; List.FData[index] := item; inc(List.FCount); end; class procedure ListHelper.InsertRange(const List: TuList; const index: integer; const Items: TArray); var i: integer; begin if Length(Items) = 0 then exit; if (index > List.Count) or (index < 0) then RaiseArgEx; if List.Count + Length(Items) > Length(List.FData) then begin SetLength(List.FData, GetNextCapacity(List.FCount + Length(Items))); end; if index < List.Count then begin Move(List.FData[index], List.FData[index + Length(Items)], SizeOf(T) * (List.Count - index)); FillChar(List.FData[index], Length(Items) * SizeOf(T), 0); //avoid having those records finalized end; for i := 0 to Length(Items) - 1 do List.FData[index + i] := Items[i]; inc(List.FCount, Length(Items)); end; class procedure ListHelper.AddManyInts(const List: TuList; const obj: UInt32; const aCount: Int32); begin if (aCount <= 0) then exit; if List.Count + aCount > Length(List.FData) then begin SetLength(List.FData, GetNextCapacity(List.FCount + aCount)); end; FillDWord(List.FData[List.Count], aCount, Obj); inc(List.FCount, aCount); end; class procedure ListHelper.AddArrayByte(const List: TuList; const Source: TArray; const aCount: Int32); begin if (aCount <= 0) then exit; if List.Count + aCount > Length(List.FData) then begin SetLength(List.FData, GetNextCapacity(List.FCount + aCount)); end; System.Move(Source[0], List.FData[List.Count], aCount * SizeOf(UInt32)); inc(List.FCount, aCount); end; class procedure ListHelper.Remove(const List: TuList; const obj: T; AComparer: IComparer); var i: Integer; begin if (AComparer = nil) then AComparer := TComparer.Default; for i := 0 to List.Count - 1 do begin if AComparer.Compare(List[i], obj) = 0 then begin Delete(List, i); exit; end; end; end; class procedure ListHelper.Reverse(const List: TuList); var i, k: integer; Tmp: T; begin k := List.Count - 1; for i := 0 to (List.Count div 2) - 1 do begin Tmp := List[i]; List[i] := List[k]; List[k] := Tmp; dec(k); end; end; class procedure ListHelper.Sort(const List: TuList; AComparer: IComparer); begin if AComparer = nil then AComparer := TComparer.Default; {$IFDEF FPC}TArrayHelper.Sort{$ELSE}TArray.Sort{$ENDIF}(List.FData, AComparer, 0, List.Count); end; class procedure ListHelper.Sort(const List: TuList); begin {$IFDEF FPC}TArrayHelper.Sort{$ELSE}TArray.Sort{$ENDIF}(List.FData, TComparer.Default, 0, List.Count); end; class procedure ListHelper.StableSort(const List: TuList; AComparer: IComparer); begin if AComparer = nil then AComparer := TComparer.Default; List.TrimExcess; // MergeSort.Sort(List.FData, AComparer); end; class function ListHelper.ToArray(const List: TuList): TArray; var i: Integer; begin SetLength(Result, List.Count); for i := 0 to Length(Result) - 1 do begin Result[i] := List[i]; end; end; { TuObjectList } procedure TuObjectList.Clear; var i: integer; begin if not DontFree then for i := 0 to FCount - 1 do TrueFree(FData[i]); inherited; end; constructor TuObjectList.Create(const aCapacity: integer; const OwnsObjects: boolean); begin inherited Create; SetLength(FData, aCapacity); DontFree := not OwnsObjects; end; procedure TuObjectList.Delete(Index: Integer); begin if not DontFree then TrueFree(Self[Index]); ListHelper.Delete(self, Index); end; procedure TuObjectList.DeleteAndNotFree(Index: Integer); begin ListHelper.Delete(self, Index); end; procedure TuObjectList.RemoveRange(Index, Count: Integer); var i: integer; begin if not DontFree then for i := Index to Index + Count - 1 do TrueFree(Self[i]); ListHelper.DeleteRange(self, Index, Count); end; destructor TuObjectList.Destroy; begin if not DontFree then Clear; inherited; end; function TuObjectList.IndexOfPointer(const Value: TObject): Integer; var i: Integer; begin for i := 0 to Count - 1 do if Items[i] = Value then Exit(i); Result := -1; end; procedure TuObjectList.Insert(Index: Integer; const Value: TObject); begin ListHelper.Insert(self, Index, Value); end; procedure TuObjectList.RemovePointer(const obj: TObject); var i: integer; begin i := IndexOfPointer(obj); if i >= 0 then Delete(i); end; procedure TuObjectList.SetButDontDestroy(const i: integer; const r: TObject); begin SetItem(i, r); end; procedure TuObjectList.SetCount(const a: integer); begin FCount := a; Capacity := a; end; { TuVListEnumerator } {$ifdef blubb} constructor TuVListEnumerator.Create(const aList: TObject); begin inherited Create; FList := aList; Position := -1; end; function TuVListEnumerator.DoGetCurrent: T; begin Result := TuList(FList)[Position]; end; function TuVListEnumerator.DoMoveNext: Boolean; begin if Position >= (TuList(FList)).Count then exit(false); inc(Position); Result := Position < (TuList(FList)).Count; end; { TuStack } procedure TuStack.Clear; begin FData := nil; FCount := 0; end; function TuStack.Count: integer; begin Result := FCount; end; function TuStack.Peek: T; begin if (FCount <= 0) then RaiseArgEx; Result := FData[FCount - 1]; end; function TuStack.Pop: T; begin if (FCount <= 0) then RaiseArgEx; dec(FCount); Result := FData[FCount]; FData[FCount] := Default(T); end; procedure TuStack.Push(const v: T); begin if FCount >= Length(FData) then begin SetLength(FData, GetNextCapacity(FCount)); end; FData[FCount] := v; inc(FCount); end; { TuStack } procedure TuOStack.Clear; begin FData := nil; FCount := 0; end; function TuOStack.Count: integer; begin Result := FCount; end; function TuOStack.Peek: T; begin if (FCount <= 0) then RaiseArgEx; Result := FData[FCount - 1]; end; procedure TuOStack.Pop; begin if (FCount <= 0) then RaiseArgEx; dec(FCount); TrueFree(FData[Count]); FData[FCount] := Default(T); end; procedure TuOStack.Push(const v: T); begin if FCount >= Length(FData) then begin SetLength(FData, GetNextCapacity(FCount)); end; FData[FCount] := v; inc(FCount); end; { TuSortedList } constructor TuSortedList.Create; begin Create(TComparer.Default); end; constructor TuSortedList.Create(const aComparer: IComparer); begin List := TuList.Create; FComparer := aComparer; end; destructor TuSortedList.Destroy; begin FreeObj(List); inherited; end; procedure TuSortedList.Add(const key: K; const value: V); var index: integer; begin index := IndexOfKey(key); if index >= 0 then RaiseArgEx; index := not index; ListHelper.Insert(List, index, TPairKV.Create(key, value)); end; procedure TuSortedList.Remove(const key: K); var index: integer; begin index := IndexOfKey(key); if index < 0 then RaiseArgEx; ListHelper.Delete(List, index); end; function TuSortedList.IndexOfKey(const key: K): integer; //begin // fails in android /iosdevice XE6 Result := ListHelper.BinarySearch(List, TPairKV.Create(key, Default(V)), TKeyComparer.Create); var L, H: Integer; mid, cmp: Integer; found: boolean; begin found := false; if Count = 0 then exit(not 0); L := 0; H := Count - 1; while L <= H do begin mid := L + (H - L) shr 1; cmp := FComparer.Compare(List[mid].Key, key); if cmp < 0 then L := mid + 1 else begin H := mid - 1; if cmp = 0 then begin found := true; end; end; end; Result := L; if (not found) then Result := not Result; end; function TuSortedList.GetItems(const key: K): V; begin Result := List[IndexOfKey(key)].Value; end; function TuSortedList.Keys(const index: integer): K; begin Result := List[index].Key; end; procedure TuSortedList.SetItems(const key: K; const value: V); var index: integer; begin index := IndexOfKey(key); if (index >= 0) then List[index] := TPairKV.Create(key, value) else Add(key, value); end; function TuSortedList.TryGetValue(const key: K; out value: V): boolean; var i: integer; begin i := IndexOfKey(key); if (i < 0) then begin value := Default(V); exit(false); end; value := List[i].Value; Result := true; end; function TuSortedList.Values(const index: integer): V; begin Result := List[index].Value; end; function TuSortedList.ContainsKey(const key: K): boolean; begin Result := IndexOfKey(key) >= 0; end; function TuSortedList.Count: integer; begin Result := List.Count; end; {$endif} (* { TKeyComparer } function TKeyComparer.Compare(const Left, Right: TPairKV): Integer; begin Result := TComparer.Default.Compare(Left.Key, Right.Key); end;*) end.