admin/expertcad
1
0
Fork 0
mirror of http://gitlab.expertsoft.com.ua/git/expertcad synced 2026-01-11 22:45:39 +02:00
Code Issues Packages Projects Releases Wiki Activity
expertcad/SRC/SCSNormBase/U_SCSLists.pas
ShevaIV 00e2ad8635 initial commit
2025-05-12 10:07:51 +03:00

2697 lines
69 KiB
ObjectPascal
Raw Blame History

unit U_SCSLists;
interface
Uses Windows, Classes, SysUtils, ComCtrls, Controls, Contnrs, idGlobal, DateUtils, RTLConsts, U_Common_Classes;
resourcestring
SInvalidFieldOffset = 'Field offset (%d) differ from first';
type
TPtrList = array of Pointer;
PPtrList = ^TPtrList;
TRapList = class(TMyObject)
private
FList: PPointerList;
FCount: Integer;
FCapacity: Integer;
FSortFieldOffset: Integer;
protected
function Get(Index: Integer): Pointer;
procedure Grow; virtual;
procedure Put(Index: Integer; Item: Pointer);
//procedure Notify(Ptr: Pointer; Action: TListNotification); virtual;
procedure SetCapacity(NewCapacity: Integer);
procedure SetCount(NewCount: Integer);
public
constructor Create;
destructor Destroy; override;
procedure Add(Item: Pointer);
procedure AddList(AList: TRapList);
procedure Clear; virtual;
procedure ClearOwnObjects;
procedure Delete(Index: Integer);
procedure DeleteRange(Index, Len: Integer);
class procedure Error(const Msg: string; Data: Integer); overload; virtual;
class procedure Error(Msg: PResStringRec; Data: Integer); overload;
procedure Exchange(Index1, Index2: Integer);
//function Expand: TRapList;
function Extract(Item: Pointer): Pointer;
function First: Pointer;
function IndexOf(Item: Pointer): Integer;
procedure Insert(Index: Integer; Item: Pointer);
function Last: Pointer;
procedure Move(CurIndex, NewIndex: Integer);
function Remove(Item: Pointer): Integer;
procedure Pack;
procedure Sort(Compare: TListSortCompare);
procedure Assign(ListA: TRapList; AOperator: TListAssignOp = laCopy; ListB: TRapList = nil);
property Capacity: Integer read FCapacity write SetCapacity;
property Count: Integer read FCount write SetCount;
property Items[Index: Integer]: Pointer read Get write Put; default;
property List: PPointerList read FList;
//property List: TPtrList read FList;
end;
TRapObjectList = class(TMyObject)
private
FItems: TRapList;
FSortFieldOffset: Integer;
FOwnsObjects: Boolean;
FAllowDuplicates: Boolean;
function FindObject(AValue: Pointer; AObject: TObject; AFieldAdress: Pointer;
var Index: Integer): Boolean;
function Get(Index: Integer): Pointer;
function GetCount: Integer;
public
constructor Create(AOwnsObjects: Boolean=false; AAllowDuplicates: Boolean=true); overload;
destructor Destroy; override;
procedure Clear;
function GetObject(AFieldValue: Integer): TObject;
function Insert(AObject: TObject; AFieldAdress: Pointer): Integer;
function Remove(AFieldValue: Integer): Integer;
property Count: Integer read GetCount;
property Items[Index: Integer]: Pointer read Get; default;
property List: TRapList read FItems;
end;
TRapRecordList = class(TRapObjectList)
private
FOwnsObjects: Boolean;
public
constructor Create(AOwnsObjects: Boolean); overload;
destructor Destroy; override;
end;
TIntList = class(TMyObject)
protected
FItems: TList;
function GetCount: Integer;
function GetItem(Index: Integer): Integer;
procedure SetItem(Index: Integer; AInt: Integer);
public
constructor Create; overload;
destructor Destroy; override;
function Add(AInt: Integer): Integer;
procedure Assign(ListA: TIntList; AOperator: TListAssignOp = laCopy; ListB: TIntList = nil);
procedure Clear;
procedure Delete(AIndex: Integer);
procedure Fill(AVal: Integer; AToIndex: Integer=-1);
procedure Move(CurrIndex, NewIndex: Integer);
function Remove(AInt: Integer): Integer;
procedure RemoveDublicates;
function RemoveItems(AItems: TIntList): Integer;
function IndexOf(AInt: Integer): Integer;
procedure Insert(Index: Integer; AInt: Integer);
property Count: Integer read GetCount;
property Items[index: integer]: Integer read GetItem write SetItem; default;
property List: TList read FItems;
end;
TIDStringList = class(TMyObject)
protected
FIDs: TIntList;
FStrings: TStringList;
function GetCount: Integer;
public
property Count: Integer read GetCount;
property IDs: TIntList read FIDs write FIDs;
property Strings: TStringList read FStrings write FStrings;
constructor Create; overload;
// Tolik 16/01/2019 --
//destructor Destroy; overload;
destructor Destroy; override;
//
function Add(AID: Integer; AString: String): Integer; overload;
function Add(AID: Integer; AString: String; AObject: TObject): Integer; overload;
procedure Assign(ListA: TIDStringList; AOperator: TListAssignOp = laCopy; ListB: TIDStringList = nil);
procedure Clear;
procedure Delete(AIndex: Integer);
function GetIDByIndex(AIndex: Integer): Integer;
function GetIDByString(AString: String): Integer;
function GetStringByID(AID: Integer): String;
function GetStringByIndex(AIndex: Integer): String;
function IndexOfByID(AID: Integer): Integer;
function IndexOfByString(AString: String): Integer;
function RemoveByID(AID: Integer): Integer;
function RemoveByString(AString: String): Integer;
end;
TBasicArrayList = class(TMyObject)
protected
FCount: Integer;
FItemsCount: Integer;
procedure Assign(ASrc: TBasicArrayList);
public
property Count: Integer read FCount;
constructor Create;
destructor Destroy; override;
procedure Clear; virtual;
end;
TConnectedComponsInfo = record
ID: Integer;
ComponWholeID: Integer;
IDConnectObject: Integer;
IDConnectCompon: Integer;
IDSideCompon: Integer;
TypeConnect: Integer;
end;
PConnectedComponsInfo = ^TConnectedComponsInfo;
TConnectedComponsList = class(TBasicArrayList)
protected
FItems: array of TConnectedComponsInfo;
function GetItem(Index: Integer): TConnectedComponsInfo;
procedure SetItem(Index: Integer; AConnectedComponsInfo: TConnectedComponsInfo);
public
constructor Create; overload;
destructor Destroy; override;
function Add(AConnectedComponsInfo: TConnectedComponsInfo): Integer;
procedure Assign(AConnectedComponsList: TConnectedComponsList);
procedure Clear; override;
procedure Delete(Index: Integer);
function GetConnectedComponsInfoByWholeID(AWholeID: Integer): TList;
function GetConnectedComponsInfoByWholeIDAndType(AWholeID, AType: Integer): TConnectedComponsInfo;
procedure GetConnectedComponsInfosByWholeID(AWholeID: Integer; var aResFrom, aResTo: TConnectedComponsInfo);
procedure InsertRecord(AComponWholeID, AIDConnectedObject,
AIDConnectedCompon, AIDSideCompon, ATypeConnect: Integer);
procedure RemoveByWholeID(AWholeID: Integer);
//function IndexOf(AConnectedComponsInfo: PConnectedComponsInfo): Integer;
//procedure Insert(Index: Integer; AConnectedComponsInfo: PConnectedComponsInfo);
property Items[index: integer]: TConnectedComponsInfo read GetItem write SetItem; default;
end;
TJoinComponsInfo = record
IDCompon1: Integer;
IDCompon2: Integer;
DBKind1: Integer;
DBKind2: Integer;
end;
TJoinComponsInfoList = class(TBasicArrayList)
protected
FItems: array of TJoinComponsInfo;
function GetItem(Index: Integer): TJoinComponsInfo;
procedure SetItem(Index: Integer; AJoinComponsInfo: TJoinComponsInfo);
public
constructor Create; overload;
destructor Destroy; override;
function Add: Integer;
function AddRecord(AIDCompon1, AIDCompon2, ADBKind1, ADBKind2: Integer): Integer;
procedure Clear;
function FindJoinComponsInfo(AIDCompon1, AIDCompon2, ADBKind1, ADBKind2: Integer): Boolean;
property Items[index: integer]: TJoinComponsInfo read GetItem write SetItem; default;
end;
TLog = class(TMyObject)
private
FDirectory: String;
FFilePrefix: String;
FFileExtension: String;
FCurrData: TDate;
FCurrFileIndex: Integer;
FCurrLog: TStringList;
FCurrLogSize: Integer;
FExistsFiles: TStringList;
FImmediateSave: Boolean;
function CheckDirectoryExists: Boolean;
procedure DefineExistsFiles;
procedure SaveStringToFile(AText, AFileName: String);
public
procedure AddStringToLog(AText: String);
constructor Create(ADirectory, AFilePrefix, AFileExtension: String; AImmediateSave: Boolean);
destructor Destroy; override;
end;
TStreamList = class(TMyObject)
private
FOwnObjects: Boolean;
FStreams: TObjectList;
FStreamsCodes: TIntList;
FFileCode: Integer;
//FFileCodeStr: string;
FFileCodeStr: AnsiString;
FISStrCode: Boolean;
FEOF: Boolean;
FFileStream: TFileStream;
FReadedStreamCode: Integer;
procedure AfterCreate(AOwnObjects: Boolean);
procedure CheckIsEnd;
public
property OwnObjects: Boolean read FOwnObjects write FOwnObjects;
property ReadedStreamCode: Integer read FReadedStreamCode;
property Streams: TObjectList read FStreams {write FStreams};
property StreamsCodes: TIntList read FStreamsCodes {write FStreamsCodes};
property EOF: Boolean read FEOF;
property FileCode: Integer read FFileCode write FFileCode;
//property FileCodeStr: string read FFileCodeStr write FFileCodeStr;
property FileCodeStr: AnsiString read FFileCodeStr write FFileCodeStr;
procedure Add(AStream: TStream; AStreamCode: Integer);
procedure Clear;
constructor Create(AFileCode: Integer; AOwnObjects: Boolean); overload;
constructor Create(AFileCode: string; AOwnObjects: Boolean); overload;
destructor Destroy; override;
function GetStreamByCode(ACode: Integer): TStream;
function LoadFromFile(AFileName: String): Boolean;
procedure ReadFileEnd;
function ReadFileHeader(AFileName: String; AFileCodeSizeToCheck: Integer): Boolean;
function ReadStreamFromFile(AStream: TStream; AAddToList: Boolean): Boolean;
procedure RotateList;
procedure SaveToFile(AFileName: String);
end;
TStringObject = class(TObject)
FString: String;
end;
TStringsHash = class
protected
FStrings: TStringList;
public
property Strings: TStringList read FStrings write FStrings;
constructor Create;
destructor Destroy; override;
function GetVal(const aKey: String; var aVal: String): Boolean;
function SetVal(const aKey, aVal: String): Integer;
end;
procedure QuickSortPointerList(SortList: PPointerList; L, R: Integer; SCompare: TListSortCompare);
procedure DeleteArrayItem(var X; const Index, ItemSize: Integer) ;
function FindInSortedIntList(AValue: Integer; AList: TIntList; var Index: Integer): Boolean;
function FindInSortedList(AValue: Pointer; AList: TList; var Index: Integer): Boolean;
function FindInSortedRapList(AValue: Pointer; AList: TRapList; var Index: Integer): Boolean;
function FindObjectInSortedRapList(AObject: TObject; AFieldAdress: Pointer;
AList: TRapList; var Index: Integer): Boolean;
function InsertObjectToSortetRapList(AObject: TObject; AFieldAdress: Pointer; AList: TRapList): Integer;
function InsertValueToSortetList(AValue: Pointer; AList: TList): Integer;
function InsertValueToSortetRapList(AValue: Pointer; AList: TRapList): Integer;
function InsertValueToSortetIntList(AValue: Integer; AList: TIntList): Integer;
function IntListToList(AIntList: TIntList): TList;
function IntListToSorted(AIntList: TIntList): TIntList;
function GetValueIndexFromSortedRapList(AValue: Pointer; AList: TRapList): Integer;
function GetValueIndexFromSortedIntList(AValue: Integer; AList: TIntList): Integer;
procedure LoadIntListFromStream(AStream: TStream; AIntList: TIntList);
procedure SaveIntListToStream(AStream: TStream; AIntList: TIntList);
function AddStrObjToStrings(AStrings: TStrings; const AKeyStr, AStrObj: String): Integer;
function GetObjFromStringsByStr(AStrings: TStrings; const AStr: String): TObject;
function GetStrFromStringsByKey(AStrings: TStrings; const AKey: String): String;
function GetStrFromStringsByIdx(AStrings: TStrings; AIdx: Integer): String;
procedure FreeStringsObjects(AStrings: TStrings; AClear: Boolean);
procedure SetStrToStringsByIdx(AStrings: TStrings; AIdx: Integer; const aVal: String);
procedure SortListByItemField(AList: TList; AItem, AFieldAdress: Pointer);
//procedure SortListByObjItemField(AList: TList; AItem: TObject; AFieldAdress: Pointer);
procedure RotateTObjectList(AList: TObjectList);
procedure RotateTList(AList: TList);
implementation
Uses U_BaseCommon;
{ TRapList }
constructor TRapList.Create;
begin
inherited;
//FAddBy := 10;
FSortFieldOffset := -1;
end;
destructor TRapList.Destroy;
begin
Clear;
inherited;
end;
procedure TRapList.Add(Item: Pointer);
//var
//Delta: Integer;
begin
{Result := FCount;
if Result = FCapacity then
Grow;
FList^[Result] := Item;
Inc(FCount);
if Item <> nil then
Notify(Item, lnAdded);}
//if FCount = FCapacity then
// Grow;
//FList^[FCount] := Item;
//Inc(FCount);
if FCapacity <= FCount then
begin
//Capacity := FCount + FAddBy;
{if FCapacity > 64 then
Delta := FCapacity div 4
else
if FCapacity > 8 then
Delta := 16
else
Delta := 4;
Capacity := FCount + Delta;}
Grow;
end;
FList^[FCount] := Item;
FCount := FCount + 1; //Inc(FCount);
end;
procedure TRapList.AddList(AList: TRapList);
var
NewCount: Integer;
Delta: Integer;
i: Integer;
begin
NewCount := FCount + AList.FCount;
if FCapacity <= NewCount then
begin
if FCapacity > 64 then
Delta := FCapacity div 4
else
if FCapacity > 8 then
Delta := 16
else
Delta := 4;
Capacity := NewCount + Delta;
end;
for i := 0 to AList.FCount - 1 do
FList^[FCount + i] := AList.FList^[i];
FCount := NewCount;
end;
procedure TRapList.Clear;
var i, j: Integer;
begin
//Tolik
if FCount > 0 then
begin
while FCount > 0 do
Delete(0);
end;
//
SetCount(0);
SetCapacity(0);
end;
procedure TRapList.ClearOwnObjects;
var
i: Integer;
begin
for i := 0 to FCount - 1 do
begin
if FList^[i] <> nil then
TObject(FList^[i]).Free;
end;
Clear;
end;
procedure TRapList.Delete(Index: Integer);
//var
//Temp: Pointer;
begin
{if (Index < 0) or (Index >= FCount) then
Error(@SListIndexError, Index);
Temp := Items[Index];
Dec(FCount);
if Index < FCount then
System.Move(FList^[Index + 1], FList^[Index],
(FCount - Index) * SizeOf(Pointer));
if Temp <> nil then
Notify(Temp, lnDeleted);}
//DeleteRange(Index, 1);
if (Index < 0) or (Index >= FCount) then
Error(@SListIndexError, Index);
FCount := FCount - 1;
//if Index < FCount - 1 then
//Tolik
//if Index < FCount then
if Index <= FCount then // (<28> <20><> <20><><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> 1)
//
begin
//FCount := FCount - 1;
System.Move(FList^[Index + 1], FList^[Index], (FCount - Index) * SizeOf(Pointer));
end;
end;
procedure TRapList.DeleteRange(Index, Len: Integer);
begin
if Len <= 0 then
Exit;
if (Index < 0) or (Index >= FCount) then
Error(@SListIndexError, Index);
if Index + Len > FCount then
Len := FCount - Index;
//<2F><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>, <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
if (Index + Len) < FCount then
System.Move(FList^[ Index + Len ], FList^[ Index ], Sizeof( Pointer ) * (FCount - Index - Len) );
FCount := FCount - Len; //Dec( fCount, Len );
end;
class procedure TRapList.Error(const Msg: string; Data: Integer);
function ReturnAddr: Pointer;
asm
MOV EAX,[EBP+4]
end;
begin
raise EListError.CreateFmt(Msg, [Data]) at ReturnAddr;
end;
class procedure TRapList.Error(Msg: PResStringRec; Data: Integer);
begin
TRapList.Error(LoadResString(Msg), Data);
end;
procedure TRapList.Exchange(Index1, Index2: Integer);
var
Item: Pointer;
begin
if (Index1 < 0) or (Index1 >= FCount) then
Error(@SListIndexError, Index1);
if (Index2 < 0) or (Index2 >= FCount) then
Error(@SListIndexError, Index2);
Item := FList^[Index1];
FList^[Index1] := FList^[Index2];
FList^[Index2] := Item;
end;
{
function TRapList.Expand: TRapList;
begin
if FCount = FCapacity then
Grow;
Result := Self;
end;}
function TRapList.First: Pointer;
begin
Result := Get(0);
end;
function TRapList.Get(Index: Integer): Pointer;
begin
if (Index < 0) or (Index >= FCount) then
Error(@SListIndexError, Index);
Result := FList^[Index];
end;
procedure TRapList.Grow;
var
Delta: Integer;
begin
if FCapacity > 64 then
Delta := FCapacity div 4
else
if FCapacity > 8 then
Delta := 16
else
Delta := 4;
SetCapacity(FCapacity + Delta);
end;
function TRapList.IndexOf(Item: Pointer): Integer;
var
i: Integer;
MiddleIndex: Integer;
LastIndex: Integer;
begin
//Result := 0;
//while (Result < FCount) and (FList^[Result] <> Item) do
// Inc(Result);
//if Result = FCount then
// Result := -1;
Result := -1;
for i := 0 to FCount - 1 do
if FList^[i] = Item then
begin
Result := i;
Break; //// BREAK ////
end;
{
Result := -1;
MiddleIndex := FCount div 2;
if (FCount mod 2) <> 0 then
MiddleIndex := MiddleIndex + 1;
LastIndex := FCount - 1;
for i := 0 to MiddleIndex - 1 do
if FList^[i] = Item then
begin
Result := i;
Break; //// BREAK ////
end
else
if FList^[LastIndex - i] = Item then
begin
Result := i;
Break; //// BREAK ////
end; }
end;
procedure TRapList.Insert(Index: Integer; Item: Pointer);
begin
{if (Index < 0) or (Index > FCount) then
Error(@SListIndexError, Index);
if FCount = FCapacity then
Grow;
if Index < FCount then
System.Move(FList^[Index], FList^[Index + 1],
(FCount - Index) * SizeOf(Pointer));
FList^[Index] := Item;
Inc(FCount);
if Item <> nil then
Notify(Item, lnAdded);}
if (Index < 0) or (Index > FCount) then
Error(@SListIndexError, Index);
if FCount = FCapacity then
Grow;
if Index < FCount then
System.Move(FList^[Index], FList^[Index + 1], (FCount - Index) * SizeOf(Pointer));
FList^[Index] := Item;
FCount := FCount + 1;
end;
function TRapList.Last: Pointer;
begin
Result := Get(FCount - 1);
end;
procedure TRapList.Move(CurIndex, NewIndex: Integer);
var
Item: Pointer;
begin
if CurIndex <> NewIndex then
begin
if (NewIndex < 0) or (NewIndex >= FCount) then
Error(@SListIndexError, NewIndex);
Item := Get(CurIndex);
FList^[CurIndex] := nil;
Delete(CurIndex);
Insert(NewIndex, nil);
FList^[NewIndex] := Item;
end;
end;
procedure TRapList.Put(Index: Integer; Item: Pointer);
//var
//Temp: Pointer;
begin
{if (Index < 0) or (Index >= FCount) then
Error(@SListIndexError, Index);
if Item <> FList^[Index] then
begin
Temp := FList^[Index];
FList^[Index] := Item;
if Temp <> nil then
Notify(Temp, lnDeleted);
if Item <> nil then
Notify(Item, lnAdded);
end;}
if (Index < 0) or (Index >= FCount) then
Error(@SListIndexError, Index);
FList^[Index] := Item;
end;
function TRapList.Remove(Item: Pointer): Integer;
begin
Result := IndexOf(Item);
if Result >= 0 then
Delete(Result);
end;
procedure TRapList.Pack;
var
I: Integer;
begin
for I := FCount - 1 downto 0 do
if Items[I] = nil then
Delete(I);
end;
procedure TRapList.SetCapacity(NewCapacity: Integer);
begin
{if (NewCapacity < FCount) or (NewCapacity > MaxListSize) then
Error(@SListCapacityError, NewCapacity);
if NewCapacity <> FCapacity then
begin
ReallocMem(FList, NewCapacity * SizeOf(Pointer));
FCapacity := NewCapacity;
end;}
if NewCapacity < FCount then
NewCapacity := FCount;
if NewCapacity <> FCapacity then
begin
ReallocMem(FList, NewCapacity * SizeOf(Pointer));
FCapacity := NewCapacity;
end;
end;
procedure TRapList.SetCount(NewCount: Integer);
//var
//I: Integer;
begin
{
if (NewCount < 0) or (NewCount > MaxListSize) then
Error(@SListCountError, NewCount);
if NewCount > FCapacity then
SetCapacity(NewCount);
if NewCount > FCount then
FillChar(FList^[FCount], (NewCount - FCount) * SizeOf(Pointer), 0)
else
for I := FCount - 1 downto NewCount do
Delete(I);
FCount := NewCount;}
if NewCount >= FCount then
Exit;
FCount := NewCount;
end;
procedure QuickSortPointerList(SortList: PPointerList; L, R: Integer;
SCompare: TListSortCompare);
var
I, J: Integer;
P, T: Pointer;
begin
repeat
I := L;
J := R;
P := SortList^[(L + R) shr 1];
repeat
while SCompare(SortList^[I], P) < 0 do
Inc(I);
while SCompare(SortList^[J], P) > 0 do
Dec(J);
if I <= J then
begin
T := SortList^[I];
SortList^[I] := SortList^[J];
SortList^[J] := T;
Inc(I);
Dec(J);
end;
until I > J;
if L < J then
QuickSortPointerList(SortList, L, J, SCompare);
L := I;
until I >= R;
end;
procedure TRapList.Sort(Compare: TListSortCompare);
begin
if (FList <> nil) and (Count > 0) then
QuickSortPointerList(FList, 0, Count - 1, Compare);
end;
function TRapList.Extract(Item: Pointer): Pointer;
var
I: Integer;
begin
{Result := nil;
I := IndexOf(Item);
if I >= 0 then
begin
Result := Item;
FList^[I] := nil;
Delete(I);
Notify(Result, lnExtracted);
end; }
Result := nil;
I := IndexOf(Item);
if I >= 0 then
begin
Result := Item;
FList^[I] := nil;
Delete(I);
end;
end;
//procedure TRapList.Notify(Ptr: Pointer; Action: TListNotification);
//begin
//end;
procedure TRapList.Assign(ListA: TRapList; AOperator: TListAssignOp; ListB: TRapList);
var
I: Integer;
LTemp, LSource: TRapList;
begin
// ListB given?
if ListB <> nil then
begin
LSource := ListB;
Assign(ListA);
end
else
LSource := ListA;
// on with the show
case AOperator of
// 12345, 346 = 346 : only those in the new list
laCopy:
begin
Clear;
Capacity := LSource.Capacity;
for I := 0 to LSource.Count - 1 do
Add(LSource[I]);
end;
// 12345, 346 = 34 : intersection of the two lists
laAnd:
for I := Count - 1 downto 0 do
if LSource.IndexOf(Items[I]) = -1 then
Delete(I);
// 12345, 346 = 123456 : union of the two lists
laOr:
for I := 0 to LSource.Count - 1 do
if IndexOf(LSource[I]) = -1 then
Add(LSource[I]);
// 12345, 346 = 1256 : only those not in both lists
laXor:
begin
LTemp := TRapList.Create; // Temp holder of 4 byte values
try
LTemp.Capacity := LSource.Count;
for I := 0 to LSource.Count - 1 do
if IndexOf(LSource[I]) = -1 then
LTemp.Add(LSource[I]);
for I := Count - 1 downto 0 do
if LSource.IndexOf(Items[I]) <> -1 then
Delete(I);
I := Count + LTemp.Count;
if Capacity < I then
Capacity := I;
for I := 0 to LTemp.Count - 1 do
Add(LTemp[I]);
finally
LTemp.Free;
end;
end;
// 12345, 346 = 125 : only those unique to source
laSrcUnique:
for I := Count - 1 downto 0 do
if LSource.IndexOf(Items[I]) <> -1 then
Delete(I);
// 12345, 346 = 6 : only those unique to dest
laDestUnique:
begin
LTemp := TRapList.Create;
try
LTemp.Capacity := LSource.Count;
for I := LSource.Count - 1 downto 0 do
if IndexOf(LSource[I]) = -1 then
LTemp.Add(LSource[I]);
Assign(LTemp);
finally
LTemp.Free;
end;
end;
end;
end;
{ TRapObjectList }
constructor TRapObjectList.Create(AOwnsObjects: Boolean=false; AAllowDuplicates: Boolean=true);
begin
inherited create;// Tolik 12/12/2019 --
FItems := TRapList.Create;
//FSortFieldOffset := -1;
FOwnsObjects := AOwnsObjects;
FAllowDuplicates := AAllowDuplicates;
Clear;
end;
destructor TRapObjectList.Destroy;
begin
FreeAndNil(FItems);
inherited;
end;
procedure TRapObjectList.Clear;
var
i: Integer;
begin
if FOwnsObjects then
for i := FItems.Count - 1 downto 0 do
TObject(FItems[i]).Free;
FItems.Clear;
FSortFieldOffset := -1;
end;
function TRapObjectList.FindObject(AValue: Pointer; AObject: TObject; AFieldAdress: Pointer;
var Index: Integer): Boolean;
var
L, H, I, C: Integer;
FieldOffset: Integer;
ValueParam: Integer;
ValueI: Integer;
begin
Result := False;
ValueParam := 0;
if AValue = nil then
begin
// <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD>
FieldOffset := Integer(Integer(AFieldAdress) - Integer(AObject));
if FSortFieldOffset = -1 then
FSortFieldOffset := FieldOffset
else
if FSortFieldOffset <> FieldOffset then
FItems.Error(@SInvalidFieldOffset, FieldOffset);
ValueParam := Integer(Pointer(AFieldAdress)^);
end
else
begin
FieldOffset := FSortFieldOffset;
ValueParam := Integer(AValue^);
end;
L := 0;
H := FItems.FCount - 1;
while L <= H do
begin
I := (L + H) shr 1;
ValueI := Integer(Pointer(Integer(FItems.FList^[I]) + FieldOffset)^);
//C := CompareStrings(FList^[I].FString, S);
if ValueI < ValueParam then //if C < 0 then
L := I + 1
else
begin
H := I - 1;
//if C = 0 then
if ValueI = ValueParam then
begin
Result := True;
L := I;
Break; //// BREAK ////
end;
end;
end;
Index := L;
end;
function TRapObjectList.Get(Index: Integer): Pointer;
begin
Result := FItems.Get(Index);
end;
function TRapObjectList.GetCount: Integer;
begin
Result := FItems.FCount;
end;
function TRapObjectList.GetObject(AFieldValue: Integer): TObject;
var
ObjectIndex: Integer;
begin
Result := nil;
if FSortFieldOffset <> -1 then
begin
if FindObject(@AFieldValue, nil, nil, ObjectIndex) then
if ObjectIndex <> -1 then
Result := TObject(FItems[ObjectIndex]);
end;
end;
function TRapObjectList.Insert(AObject: TObject; AFieldAdress: Pointer): Integer;
var
IndexToInsert: Integer;
Finded: Boolean;
begin
Result := -1;
IndexToInsert := 0;
Finded := FindObject(nil, AObject, AFieldAdress, IndexToInsert);
if Not Finded or FAllowDuplicates then
begin
FItems.Insert(IndexToInsert, TObject(AObject));
Result := IndexToInsert;
end;
end;
function TRapObjectList.Remove(AFieldValue: Integer): Integer;
var
ObjectIndex: Integer;
begin
Result := -1;
if FSortFieldOffset <> -1 then
begin
if FindObject(@AFieldValue, nil, nil, ObjectIndex) then
if ObjectIndex <> -1 then
begin
Result := ObjectIndex;
FItems.Delete(ObjectIndex);
end;
end;
end;
{ TRapRecordList }
constructor TRapRecordList.Create(AOwnsObjects: Boolean);
begin
inherited Create;
end;
destructor TRapRecordList.Destroy;
var
i: Integer;
ptrToFree: Pointer;
begin
if FOwnsObjects then
begin
for i := 0 to FItems.Count - 1 do
begin
ptrToFree := FItems.List^[i];
if ptrToFree <> nil then
FreeMem(ptrToFree);
end;
FItems.Clear;
end;
inherited;
end;
{ TIntList }
function TIntList.Add(AInt: Integer): Integer;
begin
Result := FItems.Add(Pointer(AInt)); //inherited Add(Pointer(AInt));
end;
procedure TIntList.Assign(ListA: TIntList; AOperator: TListAssignOp = laCopy; ListB: TIntList = nil);
var
LAItems: TList;
LBItems: TList;
begin
LAItems := nil;
LBItems := nil;
if Assigned(ListA) then
LAItems := ListA.FItems;
if Assigned(ListB) then
LBItems := ListB.FItems;
FItems.Assign(LAItems, AOperator, LBItems);
end;
procedure TIntList.Clear;
begin
FItems.Clear;
end;
procedure TIntList.Delete(AIndex: Integer);
begin
FItems.Delete(AIndex);
end;
procedure TIntList.Fill(AVal: Integer; AToIndex: Integer=-1);
var
i: Integer;
AddCount: Integer;
begin
for i := 0 to FItems.Count - 1 do
FItems[i] := Pointer(AVal);
AddCount := AToIndex - (FItems.Count - 1);
if AddCount > 0 then
for i := 1 to AddCount do
FItems.Add(Pointer(AVal));
end;
procedure TIntList.Move(CurrIndex, NewIndex: Integer);
begin
FItems.Move(CurrIndex, NewIndex);
end;
constructor TIntList.Create;
begin
inherited Create;
FItems := Tlist.Create;
end;
destructor TIntList.Destroy;
begin
FItems.Free;
inherited;
end;
function TIntList.GetCount: Integer;
begin
Result := FItems.Count;
end;
function TIntList.GetItem(Index: Integer): Integer;
begin
Result := Integer(FItems[Index]); //Integer(inherited Items[Index]);
end;
function TIntList.IndexOf(AInt: Integer): Integer;
var
i: Integer;
begin
Result := -1;
//Result := FItems.IndexOf(Pointer(AInt)); //inherited IndexOf(Pointer(AInt));
for i := 0 to FItems.Count - 1 do
if Integer(FItems.List^[i]) = AInt then
begin
Result := i;
Break; //// BREAK ////
end;
end;
procedure TIntList.Insert(Index, AInt: Integer);
begin
FItems.Insert(Index, Pointer(AInt)); //inherited Insert(Index, Pointer(AInt));
end;
function TIntList.Remove(AInt: Integer): Integer;
begin
Result := FItems.Remove(Pointer(AInt)); //inherited Remove(Pointer(AInt));
end;
procedure TIntList.RemoveDublicates;
var
i, j: Integer;
ValueI, ValueJ: Integer;
begin
i := 0;
while i <= FItems.Count - 1 do
begin
ValueI := Integer(FItems[i]);
j := i+1;
while j <= FItems.Count - 1 do
begin
ValueJ := Integer(FItems[j]);
if ValueJ = ValueI then
FItems.Delete(j)
else
Inc(j);
end;
Inc(i);
end;
end;
function TIntList.RemoveItems(AItems: TIntList): Integer;
var
i: Integer;
begin
for i := 0 to AItems.Count - 1 do
Remove(AItems[i]);
end;
procedure TIntList.SetItem(Index, AInt: Integer);
begin
FItems.Items[Index] := Pointer(AInt); //inherited Items[Index] := Pointer(AInt);
end;
{ TIDStringList }
constructor TIDStringList.Create;
begin
inherited;
FIDs := TIntList.Create;
FStrings := TStringList.Create;
end;
destructor TIDStringList.Destroy;
begin
FreeAndNil(FIDs);
FreeAndNil(FStrings);
inherited;
end;
function TIDStringList.Add(AID: Integer; AString: String): Integer;
begin
Result := FIDs.Add(AID);
FStrings.Add(AString);
end;
function TIDStringList.Add(AID: Integer; AString: String; AObject: TObject): Integer;
begin
Result := FIDs.Add(AID);
FStrings.AddObject(AString, AObject);
end;
procedure TIDStringList.Assign(ListA: TIDStringList; AOperator:
TListAssignOp = laCopy; ListB: TIDStringList = nil);
begin
if ListB <> nil then
FIDs.Assign(ListA.FIDs, AOperator, ListB.FIDs)
else
FIDs.Assign(ListA.FIDs, AOperator, nil);
FStrings.Assign(ListA.FStrings);
end;
procedure TIDStringList.Clear;
begin
FIDs.Clear;
FStrings.Clear;
end;
procedure TIDStringList.Delete(AIndex: Integer);
begin
FIDs.Delete(AIndex);
FStrings.Delete(AIndex);
end;
function TIDStringList.GetCount: Integer;
begin
Result := FIDs.Count;
end;
function TIDStringList.GetIDByIndex(AIndex: Integer): Integer;
begin
Result := FIDs[AIndex];
end;
function TIDStringList.GetIDByString(AString: String): Integer;
var
Index: Integer;
begin
Result := -1;
Index := FStrings.IndexOf(AString);
if Index <> -1 then
Result := FIDs.Items[Index];
end;
function TIDStringList.GetStringByID(AID: Integer): String;
var
Index: Integer;
begin
Result := '';
Index := FIDs.IndexOf(AID);
if Index <> -1 then
Result := FStrings[Index];
end;
function TIDStringList.GetStringByIndex(AIndex: Integer): String;
begin
Result := FStrings[AIndex];
end;
function TIDStringList.IndexOfByID(AID: Integer): Integer;
begin
Result := FIDs.IndexOf(AID);
end;
function TIDStringList.IndexOfByString(AString: String): Integer;
begin
Result := FStrings.IndexOf(AString);
end;
function TIDStringList.RemoveByID(AID: Integer): Integer;
var
RemIndex: Integer;
begin
RemIndex := FIDs.Remove(AID);
if RemIndex <> -1 then
FStrings.Delete(RemIndex);
Result := RemIndex;
end;
function TIDStringList.RemoveByString(AString: String): Integer;
var
RemIndex: Integer;
begin
RemIndex := FStrings.IndexOf(AString);
if RemIndex <> -1 then
begin
FIDs.Delete(RemIndex);
FStrings.Delete(RemIndex);
end;
Result := RemIndex;
end;
{ TBasicArrayList }
procedure TBasicArrayList.Assign(ASrc: TBasicArrayList);
begin
FCount := ASrc.FCount;
FItemsCount := ASrc.FItemsCount;
end;
procedure TBasicArrayList.Clear;
begin
FCount := 0;
FItemsCount := 0;
end;
constructor TBasicArrayList.Create;
begin
inherited Create;
FCount := 0;
FItemsCount := 0;
end;
destructor TBasicArrayList.Destroy;
begin
Clear;
inherited;
end;
{ TConnectedComponsList }
function TConnectedComponsList.Add(AConnectedComponsInfo: TConnectedComponsInfo): Integer;
begin
//Result := inherited Add(AConnectedComponsInfo);
Inc(FCount);
if FCount > FItemsCount then
begin
FItemsCount := FItemsCount + 200;
SetLength(FItems, FItemsCount);
end;
FItems[FCount - 1] := AConnectedComponsInfo;
Result := FCount - 1;
end;
procedure TConnectedComponsList.Assign(AConnectedComponsList: TConnectedComponsList);
begin
inherited Assign(AConnectedComponsList);
SetLength(FItems, Length(AConnectedComponsList.FItems));
FItems := AConnectedComponsList.FItems;
//CopyMemory(@FItems, @AConnectedComponsList.FItems, Length(AConnectedComponsList.FItems));
end;
procedure TConnectedComponsList.Clear;
begin
//Tolik
SetLength(FItems,0);
//
inherited;
end;
procedure TConnectedComponsList.Delete(Index: Integer);
var
Len: Integer;
begin
if Index >= FCount then
raise Exception.Create('Index out of bounds '+IntToStr(FCount - Index));
Len := High(FItems);
if index < Len then
begin
if index < FCount - 1 then
Move(FItems[Index+1], FItems[Index], (Len - Index)*SizeOf(FItems[Index]));
end;
Dec(FCount);
if FItemsCount - FCount = 200 then
begin
FItemsCount := FItemsCount - 200;
SetLength(FItems, FItemsCount);
end;
end;
function TConnectedComponsList.GetConnectedComponsInfoByWholeID(AWholeID: Integer): TList;
var
i: Integer;
ConnectedComponsInfo: TConnectedComponsInfo;
ptrConnectedComponsInfo: PConnectedComponsInfo;
begin
Result := TList.Create;
for i := 0 to Count - 1 do
begin
ConnectedComponsInfo := FItems[i];
if ConnectedComponsInfo.ComponWholeID = AWholeID then
begin
GetMem(ptrConnectedComponsInfo, SizeOf(TConnectedComponsInfo));
ptrConnectedComponsInfo^ := ConnectedComponsInfo;
Result.Add(ptrConnectedComponsInfo);
end;
end;
end;
function TConnectedComponsList.GetConnectedComponsInfoByWholeIDAndType(AWholeID, AType: Integer): TConnectedComponsInfo;
var
i: Integer;
ConnectedComponsInfo: TConnectedComponsInfo;
begin
ZeroMemory(@Result, SizeOf(TConnectedComponsInfo));
for i := 0 to FCount - 1 do
begin
ConnectedComponsInfo := FItems[i];
if (ConnectedComponsInfo.ComponWholeID = AWholeID) and
(ConnectedComponsInfo.TypeConnect = AType) then
begin
Result := ConnectedComponsInfo;
Break; ///// BREAK /////
end;
end;
end;
procedure TConnectedComponsList.GetConnectedComponsInfosByWholeID(AWholeID: Integer; var aResFrom, aResTo: TConnectedComponsInfo);
var
i: Integer;
ptrConnectedComponsInfo: PConnectedComponsInfo;
RecCnt: SmallInt;
begin
ZeroMemory(@aResFrom, SizeOf(TConnectedComponsInfo));
ZeroMemory(@aResTo, SizeOf(TConnectedComponsInfo));
RecCnt := 0;
for i := 0 to FCount - 1 do
begin
ptrConnectedComponsInfo := @FItems[i];
if ptrConnectedComponsInfo.ComponWholeID = AWholeID then
begin
if ptrConnectedComponsInfo.TypeConnect = tcoFrom then
begin
aResFrom := ptrConnectedComponsInfo^;
Inc(RecCnt);
end
else if ptrConnectedComponsInfo.TypeConnect = tcoTo then
begin
aResTo := ptrConnectedComponsInfo^;
Inc(RecCnt);
end;
if RecCnt = 2 then
Break; ///// BREAK /////
end;
end;
end;
constructor TConnectedComponsList.Create;
begin
//Tolik
Clear;
//
inherited Create;
end;
destructor TConnectedComponsList.Destroy;
begin
Clear;
inherited;
end;
function TConnectedComponsList.GetItem(Index: Integer): TConnectedComponsInfo;
begin
Result := FItems[Index]; //PConnectedComponsInfo(inherited Items[Index]);
end;
procedure TConnectedComponsList.RemoveByWholeID(AWholeID: Integer);
var
ConnectedComponsInfo: TConnectedComponsInfo;
i: Integer;
begin
i := 0;
while i <= FCount - 1 do
begin
ConnectedComponsInfo := Items[i];
if ConnectedComponsInfo.ComponWholeID = AWholeID then
begin
Delete(i);
//Remove(ptrConnectedComponsInfo);
//FreeMem(ptrConnectedComponsInfo);
end
else
Inc(i);
end;
{ptrConnectedComponsInfo := GetConnectedComponsInfoByWholeIDAndType(AWholeID, tcoFrom);
if ptrConnectedComponsInfo <> nil then
begin
Remove(ptrConnectedComponsInfo);
FreeMem(ptrConnectedComponsInfo);
end;
ptrConnectedComponsInfo := GetConnectedComponsInfoByWholeIDAndType(AWholeID, tcoTo);
if ptrConnectedComponsInfo <> nil then
begin
Remove(ptrConnectedComponsInfo);
FreeMem(ptrConnectedComponsInfo);
end;}
end;
procedure TConnectedComponsList.InsertRecord(AComponWholeID, AIDConnectedObject,
AIDConnectedCompon, AIDSideCompon, ATypeConnect: Integer);
var
ConnectedComponsInfo: TConnectedComponsInfo;
begin
ZeroMemory(@ConnectedComponsInfo, SizeOf(TConnectedComponsInfo));
ConnectedComponsInfo.ID := 0;
ConnectedComponsInfo.ComponWholeID := AComponWholeID;
ConnectedComponsInfo.IDConnectObject := AIDConnectedObject;
ConnectedComponsInfo.IDConnectCompon := AIDConnectedCompon;
ConnectedComponsInfo.IDSideCompon := AIDSideCompon;
ConnectedComponsInfo.TypeConnect := ATypeConnect;
Add(ConnectedComponsInfo);
end;
procedure TConnectedComponsList.SetItem(Index: Integer;
AConnectedComponsInfo: TConnectedComponsInfo);
begin
FItems[Index] := AConnectedComponsInfo; //inherited Items[Index] := AConnectedComponsInfo;
end;
{ TJoinComponsInfoList }
function TJoinComponsInfoList.Add: Integer;
begin
FCount := FCount + 1;
if FCount > FItemsCount then
begin
FItemsCount := FItemsCount + 200;
SetLength(FItems, FItemsCount);
end;
//FItems[FCount - 1] := AJoinComponsInfo;
Result := FCount - 1;
end;
function TJoinComponsInfoList.AddRecord(AIDCompon1, AIDCompon2,
ADBKind1, ADBKind2: Integer): Integer;
//var
//JoinComponsInfo: TJoinComponsInfo;
begin
{//11.03.2009
Result := -1;
ZeroMemory(@JoinComponsInfo, SizeOf(TJoinComponsInfo));
JoinComponsInfo.IDCompon1 := AIDCompon1;
JoinComponsInfo.IDCompon2 := AIDCompon2;
JoinComponsInfo.DBKind1 := ADBKind1;
JoinComponsInfo.DBKind2 := ADBKind2;
Result := Add(JoinComponsInfo);
}
Result := Add;
FItems[Result].IDCompon1 := AIDCompon1;
FItems[Result].IDCompon2 := AIDCompon2;
FItems[Result].DBKind1 := ADBKind1;
FItems[Result].DBKind2 := ADBKind2;
end;
procedure TJoinComponsInfoList.Clear;
begin
SetLength(FItems, 0);
inherited;
end;
constructor TJoinComponsInfoList.Create;
begin
//Tolik
Clear;
//
inherited Create;
end;
destructor TJoinComponsInfoList.Destroy;
begin
// Tolik
Clear;
//
inherited;
end;
function TJoinComponsInfoList.GetItem(Index: Integer): TJoinComponsInfo;
begin
Result := FItems[Index]; //PJoinComponsInfo(inherited Items[Index]);
end;
function TJoinComponsInfoList.FindJoinComponsInfo(AIDCompon1,
AIDCompon2, ADBKind1, ADBKind2: Integer): Boolean;
var
i: Integer;
JoinComponsInfo: TJoinComponsInfo;
begin
Result := false;
for i := 0 to FCount - 1 do
begin
JoinComponsInfo := FItems[i];
if ((JoinComponsInfo.IDCompon1 = AIDCompon1) and (JoinComponsInfo.IDCompon2 = AIDCompon2) and
(JoinComponsInfo.DBKind1 = ADBKind1) and (JoinComponsInfo.DBKind2 = ADBKind2)) or
((JoinComponsInfo.IDCompon1 = AIDCompon2) and (JoinComponsInfo.IDCompon2 = AIDCompon1) and
(JoinComponsInfo.DBKind1 = ADBKind2) and (JoinComponsInfo.DBKind2 = ADBKind1)) then
begin
Result := true;
Break; ///// BREAK /////
end;
end;
end;
procedure TJoinComponsInfoList.SetItem(Index: Integer;
AJoinComponsInfo: TJoinComponsInfo);
begin
Items[Index] := AJoinComponsInfo;
end;
{ TLog }
function TLog.CheckDirectoryExists: Boolean;
begin
Result := false;
if Not DirectoryExists(FDirectory) then
CreateDir(FDirectory);
if DirectoryExists(FDirectory) then
Result := true;
end;
procedure TLog.DefineExistsFiles;
var
SearchRec: TSearchRec;
DirName: String;
FileAttrs: Integer;
begin
DirName := FDirectory;
if DirName[Length(DirName)] <> '\' then
DirName := DirName + '\';
FileAttrs := faAnyFile + faHidden;
if FindFirst(DirName + '*.*', FileAttrs, SearchRec) <> 0 then
begin
repeat
if (SearchRec.Attr and FileAttrs) = SearchRec.Attr then
if Pos(FFilePrefix, SearchRec.Name) = 1 then
FExistsFiles.Add(SearchRec.Name);
until FindNext(SearchRec) <> 0;
FindClose(SearchRec);
end;
end;
procedure TLog.SaveStringToFile(AText, AFileName: String);
var
FHandle: TextFile;
begin
if FileExists(AFileName) then
Append(FHandle)
else
Rewrite(FHandle);
try
WriteLn(FHandle, AText);
finally
CloseFile(FHandle);
end;
end;
procedure TLog.AddStringToLog(AText: String);
var
TextLength: Integer;
FileName: String;
NewData: TDate;
begin
TextLength := Length(AText);
NewData := Date;
if (FCurrData <> NewData) then
begin
FileName := FFilePrefix + '_'+
IntToStrF(YearOf(NewData), 4)+
IntToStrF(MonthOf(NewData), 2)+
IntToStrF(DayOf(NewData), 2)+'.'+FFileExtension;
FCurrLogSize := 0;
FCurrFileIndex := 0;
end;
if FileName = '' then
if ((FCurrLogSize + TextLength) > 2048) then
begin
end;
if FImmediateSave then
begin
end
else
begin
end;
end;
constructor TLog.Create(ADirectory, AFilePrefix, AFileExtension: String; AImmediateSave: Boolean);
begin
inherited Create;
FDirectory := ADirectory + '\';
FFilePrefix := AFilePrefix;
FFileExtension := AFileExtension;
FImmediateSave := AImmediateSave;
FCurrData := Date;
FCurrFileIndex := 0;
FCurrLog := nil;
FCurrLogSize := 0;
if Not AImmediateSave then
FCurrLog := TStringList.Create;
FExistsFiles := TStringList.Create;
if CheckDirectoryExists then
DefineExistsFiles;
end;
destructor TLog.Destroy;
begin
if Assigned(FCurrLog) then
FreeAndNil(FCurrLog);
if Assigned(FExistsFiles) then
FreeAndNil(FExistsFiles);
inherited;
end;
function AddStrObjToStrings(AStrings: TStrings; const AKeyStr, AStrObj: String): Integer;
var
StringObject: TStringObject;
begin
Result := -1;
StringObject := TStringObject.Create;
StringObject.FString := AStrObj;
Result := AStrings.AddObject(AKeyStr, StringObject);
end;
procedure DeleteArrayItem(var X; const Index, ItemSize: Integer);
begin
{if Index > High(X) then
Exit;
if Index < Low(X) then
Exit;
if Index = High(X) then
begin
SetLength(X, Length(X) - 1) ;
Exit;
end;
Finalize(X[Index]) ;
System.Move(X[Index +1], X[Index],(Length(X) - Index -1) * ItemSize + 1);
SetLength(X, Length(X) - 1);}
end;
function FindInSortedIntList(AValue: Integer; AList: TIntList; var Index: Integer): Boolean;
var
L, H, I, C: Integer;
begin
Result := False;
L := 0;
H := AList.Count - 1;
while L <= H do
begin
I := (L + H) shr 1;
//C := CompareStrings(FList^[I].FString, S);
if Integer(AList.List.List^[I]) < AValue then //if C < 0 then
L := I + 1
else
begin
H := I - 1;
//if C = 0 then
if Integer(AList.List.List^[I]) = AValue then
begin
Result := True;
L := I;
Break; //// BREAK ////
end;
end;
end;
Index := L;
end;
function FindInSortedList(AValue: Pointer; AList: TList; var Index: Integer): Boolean;
var
L, H, I, C: Integer;
begin
Result := False;
L := 0;
H := AList.Count - 1;
while L <= H do
begin
I := (L + H) shr 1;
//C := CompareStrings(FList^[I].FString, S);
if Integer(AList.List^[I]) < Integer(AValue) then //if C < 0 then
L := I + 1
else
begin
H := I - 1;
//if C = 0 then
if Integer(AList.List^[I]) = Integer(AValue) then
begin
Result := True;
L := I;
Break; //// BREAK ////
end;
end;
end;
Index := L;
end;
function FindInSortedRapList(AValue: Pointer; AList: TRapList; var Index: Integer): Boolean;
var
L, H, I, C: Integer;
begin
Result := False;
L := 0;
H := AList.FCount - 1;
while L <= H do
begin
I := (L + H) shr 1;
//C := CompareStrings(FList^[I].FString, S);
if LongInt(AList.FList^[I]) < LongInt(AValue) then //if C < 0 then
L := I + 1
else
begin
H := I - 1;
//if C = 0 then
if LongInt(AList.FList^[I]) = LongInt(AValue) then
begin
Result := True;
L := I;
Break; //// BREAK ////
end;
end;
end;
Index := L;
end;
function FindObjectInSortedRapList(AObject: TObject; AFieldAdress: Pointer;
AList: TRapList; var Index: Integer): Boolean;
var
L, H, I, C: Integer;
FieldOffset: Integer;
ValueParam: Integer;
ValueI: Integer;
begin
Result := False;
// <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD>
FieldOffset := Integer(Integer(AFieldAdress) - Integer(AObject));
if AList.FSortFieldOffset = -1 then
AList.FSortFieldOffset := FieldOffset;
ValueParam := Integer(Pointer(AFieldAdress)^);
L := 0;
H := AList.FCount - 1;
while L <= H do
begin
I := (L + H) shr 1;
ValueI := Integer(Pointer(Integer(AList.FList^[I]) + FieldOffset)^);
//C := CompareStrings(FList^[I].FString, S);
if ValueI < ValueParam then //if C < 0 then
L := I + 1
else
begin
H := I - 1;
//if C = 0 then
if ValueI = ValueParam then
begin
Result := True;
Break; //// BREAK ////
end;
end;
end;
Index := L;
end;
function InsertObjectToSortetRapList(AObject: TObject; AFieldAdress: Pointer; AList: TRapList): Integer;
var
IndexToInsert: Integer;
begin
Result := -1;
IndexToInsert := 0;
//FindInSortedRapList(AValue, AList, IndexToInsert);
FindObjectInSortedRapList(AObject, AFieldAdress, AList, IndexToInsert);
AList.Insert(IndexToInsert, TObject(AObject));
Result := IndexToInsert;
end;
function InsertValueToSortetList(AValue: Pointer; AList: TList): Integer;
var
IndexToInsert: Integer;
begin
FindInSortedList(AValue, AList, IndexToInsert);
AList.Insert(IndexToInsert, Pointer(AValue));
Result := IndexToInsert;
end;
function InsertValueToSortetRapList(AValue: Pointer; AList: TRapList): Integer;
var
FirstIndex: Integer;
LastIndex: Integer;
MidleIndex: Integer;
IndexToInsert: Integer;
begin
Result := -1;
IndexToInsert := 0;
{if Alist.Count > 0 then
begin
FirstIndex := 0;
LastIndex := AList.Count - 1;
while FirstIndex <= LastIndex do
begin
if LongInt(Alist.List^[LastIndex]) = LongInt(AValue) then
begin
IndexToInsert := LastIndex;
Break; //// BREAK ////
end
else
begin
// <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
MidleIndex := LastIndex;
if LastIndex > FirstIndex then
MidleIndex := FirstIndex + Trunc((LastIndex-FirstIndex)/2);
// <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><> <20><><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
if (MidleIndex < FirstIndex) or (MidleIndex > LastIndex) then
begin
Break; //// BREAK ////
end
else
if (LongInt(AList.List^[MidleIndex]) < LongInt(AVAlue)) and (LongInt(AVAlue) < LongInt(AList.List^[LastIndex])) then
begin
if FirstIndex = MidleIndex then
FirstIndex := MidleIndex + 1
else
FirstIndex := MidleIndex;
IndexToInsert := MidleIndex + 1;
end
else
begin
LastIndex := MidleIndex;
if LongInt(AList.List^[LastIndex]) < LongInt(AValue) then
IndexToInsert := LastIndex + 1
else
IndexToInsert := LastIndex;
end;
if FirstIndex = LastIndex then
Break; //// BREAK ////
end;
end;
end; }
FindInSortedRapList(AValue, AList, IndexToInsert);
AList.Insert(IndexToInsert, AValue);
Result := IndexToInsert;
end;
function InsertValueToSortetIntList(AValue: Integer; AList: TIntList): Integer;
var
//FirstIndex: Integer;
//LastIndex: Integer;
//MidleIndex: Integer;
IndexToInsert: Integer;
begin
Result := -1;
IndexToInsert := 0;
{if Alist.Count > 0 then
begin
FirstIndex := 0;
LastIndex := AList.Count - 1;
while FirstIndex <= LastIndex do
begin
if Alist[LastIndex] = AValue then
begin
IndexToInsert := LastIndex;
Break; //// BREAK ////
end
else
begin
// <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
if LastIndex > FirstIndex then
begin
MidleIndex := FirstIndex + Trunc((LastIndex-FirstIndex)/2);
// <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><> <20><><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
if (MidleIndex < FirstIndex) or (MidleIndex > LastIndex) then
begin
Break; //// BREAK ////
end
else
if AList[MidleIndex] < AVAlue then
begin
if FirstIndex = MidleIndex then
FirstIndex := MidleIndex + 1
else
FirstIndex := MidleIndex;
end
else
begin
LastIndex := MidleIndex;
end;
end
else
begin
if AList[LastIndex] < AValue then
IndexToInsert := LastIndex + 1
else
IndexToInsert := LastIndex;
Break; //// BREAK ////
end;
end;
end;
end;}
{<7B><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
if Alist.Count > 0 then
begin
FirstIndex := 0;
LastIndex := AList.Count - 1;
while FirstIndex <= LastIndex do
begin
if Alist[LastIndex] = AValue then
begin
IndexToInsert := LastIndex;
Break; //// BREAK ////
end
else
begin
// <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
MidleIndex := LastIndex;
if LastIndex > FirstIndex then
MidleIndex := FirstIndex + Trunc((LastIndex-FirstIndex)/2);
// <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><> <20><><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
if (MidleIndex < FirstIndex) or (MidleIndex > LastIndex) then
begin
Break; //// BREAK ////
end
else
if (AList[MidleIndex] < AVAlue) and (AVAlue < AList[LastIndex]) then
begin
if FirstIndex = MidleIndex then
FirstIndex := MidleIndex + 1
else
FirstIndex := MidleIndex;
IndexToInsert := MidleIndex + 1;
end
else
begin
LastIndex := MidleIndex;
if AList[LastIndex] < AValue then
IndexToInsert := LastIndex + 1
else
IndexToInsert := LastIndex;
end;
if FirstIndex = LastIndex then
Break; //// BREAK ////
end;
end;
end;}
FindInSortedIntList(AValue, AList, IndexToInsert);
AList.FItems.Insert(IndexToInsert, Pointer(AValue));
Result := IndexToInsert;
end;
function IntListToList(AIntList: TIntList): TList;
var
i: Integer;
ptrInt: ^Integer;
begin
Result := TList.Create;
for i := 0 to AIntList.Count - 1 do
begin
GetMem(ptrInt, SizeOf(Integer));
ptrInt^ := AIntList[i];
Result.Add(ptrInt);
end;
end;
function IntListToSorted(AIntList: TIntList): TIntList;
var
i: integer;
begin
Result := TIntList.Create;
for i := 0 to AIntList.Count - 1 do
InsertValueToSortetIntList(Integer(AIntList.List.List^[i]), Result);
end;
function GetObjFromStringsByStr(AStrings: TStrings; const AStr: String): TObject;
var
ObjIndex: Integer;
begin
Result := nil;
ObjIndex := AStrings.IndexOf(AStr);
if ObjIndex <> -1 then
Result := AStrings.Objects[ObjIndex];
end;
function GetValueIndexFromSortedRapList(AValue: Pointer; AList: TRapList): Integer;
//var
//FirstIndex: Integer;
//LastIndex: Integer;
//MidleIndex: Integer;
begin
Result := -1;
{try
if Alist.Count > 0 then
begin
FirstIndex := 0;
LastIndex := AList.Count - 1;
while FirstIndex <= LastIndex do
begin
if LongInt(Alist.List^[LastIndex]) = LongInt(AValue) then
begin
Result := LastIndex;
Break; //// BREAK ////
end
else
begin
// <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
if LastIndex > FirstIndex then
begin
MidleIndex := FirstIndex + Trunc((LastIndex-FirstIndex)/2);
// <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><> <20><><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
if (MidleIndex < FirstIndex) or (MidleIndex > LastIndex) then
begin
Break; //// BREAK ////
end
else
if LongInt(AList.List^[MidleIndex]) < LongInt(AVAlue) then
begin
if FirstIndex = MidleIndex then
FirstIndex := MidleIndex + 1
else
FirstIndex := MidleIndex;
end
else
begin
LastIndex := MidleIndex;
end;
end
else
Break; //// BREAK ////
end;
end;
end;
except
on E: Exception do AddExceptionToLogEx('GetValueIndexFromSortedRapList', E.Message);
end; }
if Not FindInSortedRapList(AValue, AList, Result) then
Result := -1;
end;
function GetValueIndexFromSortedIntList(AValue: Integer; AList: TIntList): Integer;
//var
//FirstIndex: Integer;
//LastIndex: Integer;
//MidleIndex: Integer;
begin
Result := -1;
{if Alist.Count > 0 then
begin
FirstIndex := 0;
LastIndex := AList.Count - 1;
while FirstIndex <= LastIndex do
begin
if Alist[LastIndex] = AValue then
begin
Result := LastIndex;
Break; //// BREAK ////
end
else
begin
// <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
if LastIndex > FirstIndex then
begin
MidleIndex := FirstIndex + Trunc((LastIndex-FirstIndex)/2);
// <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><> <20><><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
if (MidleIndex < FirstIndex) or (MidleIndex > LastIndex) then
begin
Break; //// BREAK ////
end
else
if AList[MidleIndex] < AVAlue then
begin
if FirstIndex = MidleIndex then
FirstIndex := MidleIndex + 1
else
FirstIndex := MidleIndex;
end
else
begin
LastIndex := MidleIndex;
end;
end
else
Break; //// BREAK ////
end;
end;
end; }
if Not FindInSortedIntList(AValue, AList, Result) then
Result := -1;
end;
procedure LoadIntListFromStream(AStream: TStream; AIntList: TIntList);
var
StreamSize: Integer;
StreamPos: Integer;
CurrValue: Integer;
begin
AIntList.Clear;
StreamSize := AStream.Size;
StreamPos := AStream.Position;
while StreamPos < StreamSize do
begin
AStream.ReadBuffer(CurrValue, SizeOf(Integer));
AIntList.Add(CurrValue);
StreamPos := AStream.Position;
end;
end;
procedure SaveIntListToStream(AStream: TStream; AIntList: TIntList);
var
i: Integer;
CurrValue: Integer;
begin
for i := 0 to AIntList.Count - 1 do
begin
CurrValue := AIntList[i];
AStream.WriteBuffer(CurrValue, SizeOf(Integer));
end;
end;
{ TStreamList }
procedure TStreamList.Add(AStream: TStream; AStreamCode: Integer);
begin
FStreams.Add(AStream);
FStreamsCodes.Add(AStreamCode);
end;
procedure TStreamList.AfterCreate(AOwnObjects: Boolean);
begin
FOwnObjects := AOwnObjects;
FStreams := TObjectList.Create(FOwnObjects);
FStreamsCodes := TIntList.Create;
FFileStream := nil;
Clear;
end;
procedure TStreamList.CheckIsEnd;
begin
if FFileStream.Position >= FFileStream.Size then
ReadFileEnd;
end;
procedure TStreamList.Clear;
begin
FStreams.Clear;
FStreamsCodes.Clear;
FFileCode := 0;
FFileCodeStr := '';
end;
constructor TStreamList.Create(AFileCode: Integer; AOwnObjects: Boolean);
begin
inherited create;
AfterCreate(AOwnObjects);
FFileCode := AFileCode;
FISStrCode := false;
end;
constructor TStreamList.Create(AFileCode: string; AOwnObjects: Boolean);
begin
inherited create;
AfterCreate(AOwnObjects);
FFileCodeStr := AFileCode;
FISStrCode := true;
end;
destructor TStreamList.Destroy;
begin
Clear;
FreeAndNil(FStreams);
FreeAndNil(FStreamsCodes);
inherited;
end;
function TStreamList.GetStreamByCode(ACode: Integer): TStream;
var
StreamIndex: Integer;
i: Integer;
begin
Result := nil;
StreamIndex := -1;
for i := 0 to FStreamsCodes.FItems.Count - 1 do
if Integer(FStreamsCodes.FItems.List^[i]) = ACode then
begin
StreamIndex := i;
Break; //// BREAK ////
end;
if StreamIndex <> -1 then
Result := TStream(FStreams[StreamIndex]);
end;
function TStreamList.LoadFromFile(AFileName: String): Boolean;
var
CurrStreamCode: Integer;
CurrStreamSize: Integer;
CurrStream: TMemoryStream;
begin
Result := false;
if FileExists(AFileName) then
begin
if ReadFileHeader(AFileName, 0) then
begin
//*** <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>
while Not FEOF do
begin
CurrStream := TMemoryStream.Create;
ReadStreamFromFile(CurrStream, true);
end;
Result := true;
end;
{try
//*** <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>
while FFileStream.Position < FileStream.Size do
begin
FFileStream.ReadBuffer(CurrStreamCode, SizeOf(Integer));
FFileStream.ReadBuffer(CurrStreamSize, SizeOf(Integer));
CurrStream := TMemoryStream.Create;
CurrStream.CopyFrom(FFileStream, CurrStreamSize);
CurrStream.Position := 0;
Add(CurrStream, CurrStreamCode);
end;
Result := true;
finally
FreeAndNil(FFileStream);
end;}
end;
end;
procedure TStreamList.ReadFileEnd;
begin
FEOF := true;
if FFileStream <> nil then
FreeAndNil(FFileStream);
end;
function TStreamList.ReadFileHeader(AFileName: String; AFileCodeSizeToCheck: Integer): Boolean;
var
StrSize: Integer;
FirstBlockPos: Int64;
begin
Result := false;
if FileExists(AFileName) then
begin
Clear;
FEOF := false;
if FFileStream <> nil then
FreeAndNil(FFileStream);
FFileStream := SafeOpenFileStream(AFileName, fmOpenRead, 'TStreamList.ReadFileHeader'); //TFileStream.Create(AFileName, fmOpenRead);
if FFileStream <> nil then
begin
Result := true;
FFileStream.Position := 0;
//*** <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>
if Not FISStrCode then
begin
FFileStream.ReadBuffer(FFileCode, SizeOf(Integer));
end
else
begin
FFileStream.ReadBuffer(StrSize, SizeOf(Integer));
// <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
if (AFileCodeSizeToCheck <> 0) and (AFileCodeSizeToCheck <> StrSize) then
begin
Result := false;
FEOF := true;
FreeAndNil(FFileStream);
end
else
begin
SetLength(FFileCodeStr, StrSize);
//FFileStream.ReadBuffer(pchar(FFileCodeStr)^, StrSize);
FFileStream.ReadBuffer(pAnsiChar(FFileCodeStr)^, StrSize);
end
end;
if Result then
begin
//*** <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>
FFileStream.ReadBuffer(FirstBlockPos, SizeOf(Int64));
FFileStream.Seek(FirstBlockPos, soFromBeginning);
CheckIsEnd;
end;
end;
end;
end;
function TStreamList.ReadStreamFromFile(AStream: TStream; AAddToList: Boolean): Boolean;
var
CurrStreamCode: Integer;
CurrStreamSize: Integer;
begin
Result := Not FEOF;
if Result then
begin
FFileStream.ReadBuffer(CurrStreamCode, SizeOf(Integer));
FFileStream.ReadBuffer(CurrStreamSize, SizeOf(Integer));
AStream.CopyFrom(FFileStream, CurrStreamSize);
AStream.Position := 0;
if AAddToList then
Add(AStream, CurrStreamCode);
FReadedStreamCode := CurrStreamCode;
CheckIsEnd;
end;
end;
procedure TStreamList.RotateList;
var
i: Integer;
TmpCode: Integer;
TmpStream: TObject;
ItemsCount: Integer;
IndexAtEnd: Integer;
SavedOwnsObjects: Boolean;
// Tolik 28/08/2019 --
//OldTick, CurrTick: Cardinal;
OldTick, CurrTick: DWord;
//
begin
OldTick := GetTickCount;
if FStreams.Count = FStreamsCodes.Count then
begin
SavedOwnsObjects := FStreams.OwnsObjects;
FStreams.OwnsObjects := false;
try
ItemsCount := FStreams.Count;
for i := 0 to (ItemsCount div 2) - 1 do
begin
TmpCode := FStreamsCodes[i];
TmpStream := FStreams[i];
IndexAtEnd := ItemsCount - i - 1;
FStreamsCodes[i] := FStreamsCodes[IndexAtEnd];
FStreams[i] := FStreams[IndexAtEnd];
FStreamsCodes[IndexAtEnd] := TmpCode;
FStreams[IndexAtEnd] := TmpStream;
end;
finally
FStreams.OwnsObjects := SavedOwnsObjects;
end;
end;
CurrTick := GetTickCount - OldTick;
CurrTick := GetTickCount - OldTick;
end;
procedure TStreamList.SaveToFile(AFileName: String);
var
FileStream: TFileStream;
FirstBlockPos: Int64;
CurrStream: TStream;
IntToWrite: Integer;
i: integer;
begin
if FileExists(AFileName) then
DeleteFile(AFileName);
if Not FileExists(AFileName) then
begin
FileStream := TFileStream.Create(AFileName, fmCreate);
try
FileStream.Position := 0;
//*** <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>
if Not FISStrCode then
FileStream.WriteBuffer(FFileCode, SizeOf(Integer))
else
begin
// <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
IntToWrite := Length(FFileCodeStr);
FileStream.WriteBuffer(IntToWrite, SizeOf(Integer));
// <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
//FileStream.WriteBuffer(pchar(FFileCodeStr)^, Length(FFileCodeStr));
FileStream.WriteBuffer(pAnsiChar(FFileCodeStr)^, Length(FFileCodeStr)); // Tolik 07/04/2019 --
end;
// <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>
FirstBlockPos := FileStream.Position + SizeOf(Int64);
FileStream.WriteBuffer(FirstBlockPos, SizeOf(Int64));
//*** <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>
if FStreams.Count = FStreamsCodes.Count then
for i := 0 to FStreams.Count - 1 do
begin
CurrStream := TStream(FStreams[i]);
//*** <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
IntToWrite := FStreamsCodes[i];
FileStream.WriteBuffer(IntToWrite, SizeOf(Integer));
//*** <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
IntToWrite := CurrStream.Size;
FileStream.WriteBuffer(IntToWrite, SizeOf(Integer));
//*** <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>
CurrStream.Position := 0;
FileStream.CopyFrom(CurrStream, 0);
end;
finally
FileStream.Free;
end;
end;
end;
function GetStrFromStringsByKey(AStrings: TStrings; const AKey: String): String;
var
ObjIndex: Integer;
Obj: TObject;
begin
Result := '';
ObjIndex := AStrings.IndexOf(AKey);
if ObjIndex <> -1 then
begin
Obj := AStrings.Objects[ObjIndex];
if Obj is TStringObject then
Result := TStringObject(Obj).FString;
end;
end;
function GetStrFromStringsByIdx(AStrings: TStrings; AIdx: Integer): String;
var
Obj: TObject;
begin
Result := '';
if AIdx <> -1 then
begin
Obj := AStrings.Objects[AIdx];
if Obj is TStringObject then
Result := TStringObject(Obj).FString;
end;
end;
procedure FreeStringsObjects(AStrings: TStrings; AClear: Boolean);
var
i: Integer;
Obj: TObject;
begin
for i := 0 to AStrings.Count - 1 do
begin
Obj := AStrings.Objects[i];
if Assigned(Obj) then
begin
Obj.Free;
if Not AClear then
AStrings.Objects[i] := nil;
end;
end;
if AClear then
AStrings.Clear;
end;
procedure SetStrToStringsByIdx(AStrings: TStrings; AIdx: Integer; const aVal: String);
var
Obj: TObject;
begin
if AIdx <> -1 then
begin
Obj := AStrings.Objects[AIdx];
if Obj is TStringObject then
TStringObject(Obj).FString := aVal;
end;
end;
procedure SortListByItemField(AList: TList; AItem, AFieldAdress: Pointer);
var
SortFieldOffset: Integer;
function CompareItems(Item1, Item2: Pointer): Integer;
var
val1, val2: Integer;
begin
val1 := Integer(Pointer(Integer(Item1) + SortFieldOffset)^);
val2 := Integer(Pointer(Integer(Item2) + SortFieldOffset)^);
Result := CompareInt(val1, val2);
end;
begin
if (AList <> nil) and (AList.Count > 0) then
begin
SortFieldOffset := Integer(AFieldAdress) - Integer(AItem);
QuickSortPointerList(AList.List, 0, AList.Count - 1, @CompareItems);
end;
end;
{
procedure SortListByObjItemField(AList: TList; AItem: TObject; AFieldAdress: Pointer);
var
temp: LongWord;
SortFieldOffset: LongWord;
ptr1, ptr2: LongWord;
temp2: LongWord;
function CmpItems(Item1, Item2: Pointer): Integer;
var
//ptr1, ptr2: LongWord;
val1, val2: Integer;
begin
//ptr1 := Pointer(LongWord(Item1) + SortFieldOffset);
//ptr2 := Pointer(LongWord(Item2) + SortFieldOffset);
ptr1 := LongWord(Item1) + SortFieldOffset;
ptr2 := LongWord(Item2) + SortFieldOffset;
val1 := Integer(Pointer(ptr1)^);
val2 := Integer(Pointer(ptr2)^);
//val1 := Integer(Pointer(Integer(Item1) + SortFieldOffset)^);
//val2 := Integer(Pointer(Integer(Item2) + SortFieldOffset)^);
Result := CompareInt(val1, val2);
end;
function CompareItems(Item1, Item2: Pointer): Integer;
begin
Result := CmpItems(Item1, Item2);
end;
begin
if (AList <> nil) and (AList.Count > 0) then
begin
SortFieldOffset := Integer(AFieldAdress) - Integer(AItem);
QuickSortPointerList(AList.List, 0, AList.Count - 1, @CompareItems);
end;
end; }
procedure RotateTObjectList(AList: TObjectList);
var
SavedOwnsObjects: Boolean;
begin
SavedOwnsObjects := AList.OwnsObjects;
AList.OwnsObjects := false;
RotateTList(AList);
AList.OwnsObjects := SavedOwnsObjects;
end;
procedure RotateTList(AList: TList);
var
i: Integer;
TmpValue: Pointer;
TmpStream: TObject;
ItemsCount: Integer;
IndexAtEnd: Integer;
SavedOwnsObjects: Boolean;
begin
ItemsCount := AList.Count;
for i := 0 to (ItemsCount div 2) - 1 do
begin
TmpValue := AList[i];
IndexAtEnd := ItemsCount - i - 1;
AList[i] := AList[IndexAtEnd];
AList[IndexAtEnd] := TmpValue;
end;
end;
{ TStringsHash }
constructor TStringsHash.Create;
begin
FStrings := CreateStringListSorted;
end;
destructor TStringsHash.Destroy;
begin
FreeStringsObjects(FStrings, True);
inherited;
end;
function TStringsHash.GetVal(const aKey: String;
var aVal: String): Boolean;
var
ResIdx: Integer;
begin
Result := false;
ResIdx := FStrings.IndexOf(aKey);
if ResIdx <> -1 then
begin
Result := true;
aVal := GetStrFromStringsByIdx(FStrings, ResIdx);
end;
end;
function TStringsHash.SetVal(const aKey, aVal: String): Integer;
begin
Result := FStrings.IndexOf(aKey);
if Result <> -1 then
begin
SetStrToStringsByIdx(FStrings, Result, aVal);
end
else
Result := AddStrObjToStrings(FStrings, aKey, aVal);
end;
end.
Reference in New Issue View Git Blame Copy Permalink