How to assign values to an array of objects in Delphi - arrays

I have an array of TBoek and and a loop that is supposed to assign values to each of the elements of the array. What happens instead is that the array ends up with the exact same values in each index. Perhaps my order of processing is incorrect or I'm incorrectly assigning values to the array, but either way I cannot for the life of me figure it out.
procedure TBoek.MaakArray;
var
i: integer;
sTitel, sOuteur, sISBN, sUitgewer, sPrys, sI: string;
boek: TBoek;
begin
boek := TBoek.Create;
for i := 0 to 9 do
begin
{$REGION 'Parse JSON om eienskappe van boek te kry'}
sI := IntToStr(i);
sTitel := JSONFile.GetValue<string>('items[' + sI + '].volumeInfo.title');
try
sOuteur := JSONFile.GetValue<string>
('items[' + sI + '].volumeInfo.authors[0]');
except
sOuteur := '<none>'
end;
try
sISBN := JSONFile.GetValue<string>
('items[' + sI + '].volumeInfo.industryIdentifiers[1].identifier');
except
sISBN := '<none>'
end;
try
sUitgewer := JSONFile.GetValue<string>
('items[' + sI + '].volumeInfo.publisher');
except
sUitgewer := '<none>'
end;
try
sPrys := JSONFile.GetValue<string>
('items[' + sI + '].saleInfo.listPrice.amount');
except
sPrys := '0';
end;
{$ENDREGION}
arrBoeke[i] := boek;
with arrBoeke[i] do
begin
SetTitel(sTitel);
SetOuteur(sOuteur);
SetISBN(sISBN);
SetUitgewer(sUitgewer);
SetPrys(sPrys);
end;
end;///end of for loop
end;
The Set functions all follow this format:
procedure TBoek.SetTitel(BoekTitel: string);
begin
fTitel := BoekTitel;
end;
This is the GetString function:
function TBoek.GetString: string;
begin
Result := GetTitel + #13#10 + GetOuteur + #13#10 + GetISBN + #13#10 +
GetUitgewer + #13#10 + GetPrys + #13#10 + #13#10;
end;
And the GetTitel,GetOuteur etc. functions all follow the same format:
function TBoek.GetTitel: string;
begin
Result := fTitel;
end;
What I want is to call:
for I := 0 to 9 do
begin
ShowMessage(arrBoeke[i].GetString);
end;
and access the values in the array one at a time, instead each value is the same.

Related

AsStreams FireDAC got nil value from MemoryStream

i was trying to insert a lot of info into my database Access and i am stuck on this exemple:
(TableContact.FieldByName('foto') as TBlobField).SaveToStream(AQuery.Params.ParamByName('pFoto').AsStreams[I];
Always my AsStreams[I] is nil
Trying to get it solved i tryed to do an loop adding my Streams into an Array and then insert them into my AsStreams[I], but it was the same error (nil).
Exemple:
for I := 0 to Streams.Count - 1 do
(AQuery.Params.ParamByName('pFoto').AsStreams[I] as TBlobField).LoadFromStream(Streams[I]);
Anyone could help me?
Full code downhere
procedure TPrincipalController.SetDadosMemTableToBanco;
var
I: Integer;
AQuery: TFDQuery;
function GetSQLMemTableToBanco: String;
begin
Result :=
'INSERT INTO PESSOA (nome, telefone, email, foto, observacoes) ' + sLineBreak +
' VALUES (:pNome, :pTelefone, :pEmail, :pFoto, :pObservacoes); ';
end;
function GetSQLMemTableUpdateToBanco: String;
begin
Result :=
'UPDATE PESSOA ' + sLineBreak +
' SET nome = :pNome, ' + sLineBreak +
' telefone = :pTelefone, ' + sLineBreak +
' email = :pEmail, ' + sLineBreak +
' foto = :pFoto, ' + sLineBreak +
' observacoes = :pObservacoes ' + sLineBreak +
' WHERE id = :pID; ';
end;
procedure SetArraySizeOnSQLChange;
begin
AQuery.Params.ArraySize := FTableContatos.RecordCount;
end;
begin
try
AQuery := TFDQuery.Create(nil);
try
AQuery.Connection := TConexao.GetConexao;
TableContatos.First;
for I := 0 to TableContatos.RecordCount - 1 do
begin
AQuery.SQL.Text := GetSQLMemTableToBanco;
SetArraySizeOnSQLChange;
if ExisteRegistro(TableContatos.FieldByName('id').AsInteger) then
begin
AQuery.SQL.Text := GetSQLMemTableUpdateToBanco;
SetArraySizeOnSQLChange;
AQuery.ParamByName('pID').AsIntegers[I] := TableContatos.FieldByName('id').AsInteger;
end;
AQuery.ParamByName('pNome').AsStrings[I] := TableContatos.FieldByName('nome').AsString;
AQuery.ParamByName('pTelefone').AsStrings[I] := TableContatos.FieldByName('telefone').AsString;
AQuery.ParamByName('pEmail').AsStrings[I] := TableContatos.FieldByName('email').AsString;
AQuery.ParamByName('pObservacoes').AsStrings[I] := TableContatos.FieldByName('observacoes').AsString;
(TableContatos.FieldByName('foto') as TBlobField).SaveToStream(AQuery.Params.ParamByName('pFoto').AsStreams[I]);
TableContatos.Next;
end;
AQuery.Execute(TableContatos.RecordCount, 0);
finally
AQuery.Free;
end;
except
on E: Exception do
ShowMessageFmt('Erro ao incluir dados no banco. MSG -> %s', [E.Message]);
end;
end;
Solved using only Update on SQL and the attribution to the Field i needed to use like this:
AStream := TableContatos.CreateBlobStream(TableContatos.FieldByName('foto'), TBlobStreamMode.bmRead);
try
AQuery.ParamByName('pFoto').LoadFromStream(AStream, ftBlob, I);
finally
AStream.Free;
end;

How to copy an OleVariant array efficiently to my own structure?

I am trying to copy an OleVariant array to my own structure. I received the OleVariant from an external COM call.
The size is 1000 x 500 elements (I don't know if its the same as this Structure Definition: array of array of OleVariant).
Currently, I am trying to achieve something like:
result := Copy(Source, Amount)
But the OleVariant structure is in my way.
If I use a "classical" loop, it works, but it is slow (very slow).
aResult is currently defined as TData = array of array of string;
procedure CopyResult(aResultCount: Integer; var aResult: TData; aSource: Variant);
var
i, j: Integer;
bVariantConversion: boolean;
begin
SetLength(aResult, aResultCount, VarArrayHighBound(aSource[0], 1));
bVariantConversion := NullStrictConvert; // settings to manage how string conversion for Variant is handled.
NullStrictConvert := False;
try
for i := VarArrayLowBound(aSource, 1) to VarArrayHighBound(aSource, 1) do
begin
for j := VarArrayLowBound(aSource[i], 1) to pred(VarArrayHighBound(aSource[i], 1)) do
begin
//nearly every execution pause is somewhere in this String Conversion or Array Function.
aResult[i][j] := aSource[i][j]; //implicit conversion to string ...
end;
end;
finally
NullStrictConvert := bVariantConversion;
end;
end;
As #Remy Lebau mentioned the bounds Check for the Vararray[x][y] access is the routine my source burns its time. I am trying to eliminate this kind of acces by going directly to the OleVariantArray Elements.
Aftermath...
trying to Determine my Structure i think i found the Root.
tmyVarType := VarType(aSource); //8204 => Array(VT_ARRAY = 0x2000 = 8192) + variant(VT_VARIANT = 0x000C = 12)
tmyVarType := VarType(aSource[0]); //8204
tmyVarType := VarType(aSource[0][0]); //3 VT_I4 = 0x0003 = 3 is integer and this is correctly changin for the fields.
So i try to acess the Source without the build in functions to avoid the bounds check.
The biggest bottleneck in this code is the bounds checking performed by the [] operator on each Variant array, and potentially on your aResult array, too. Since you are already handling the bounds in each loop, there is no need to verify the bounds inside of the loops as well.
So, if performance is an issue for you, then you can use VarArrayLock() to access the underlying Variant elements in each array, using pointer arithmetic to move between them, eliminating those redundant bounds checks.
You should also reduce the redundant calls to VarArray(Low|High)Bound(aSource[i], 1) on each iteration of the outer array, since you claim the inner arrays all have the same length. So you can calculate that up front before entering the loops.
Try something like this:
type
TStrArr = array of string;
PStrArr = ^TStrArr;
TData = array of TStrArr;
procedure CopyResult(aResultCount: Integer; var aResult: TData; aSource: Variant);
var
i, j,
OuterLBound, OuterHBound, OuterCount,
InnerLBound, InnerHBound, InnerCount: Integer;
pOuterVarArr, pInnerVarArr: PVariant;
pOuterDynArr: PStrArr;
pInnerDynArr: PString;
bVariantConversion: boolean;
begin
aResult := nil;
Assert(VarIsType(aSource, varArray or varVariant));
Assert(VarArrayDimCount(aSource) = 1);
OuterLBound := VarArrayLowBound(aSource, 1);
OuterHBound := VarArrayHighBound(aSource, 1);
OuterCount := {aResultCount} OuterHBound - OuterLBound + 1;
if OuterCount < 1 then Exit;
Assert(VarIsType(aSource[0], varArray or varVariant));
Assert(VarArrayDimCount(aSource[0]) = 1);
InnerLBound := VarArrayLowBound(aSource[0], 1);
InnerHBound := VarArrayHighBound(aSource[0], 1);
InnerCount := InnerHBound - InnerLBound + 1;
SetLength(aResult, {aResultCount} OuterCount, InnerCount);
bVariantConversion := NullStrictConvert; // settings to manage how string conversion for Variant is handled.
NullStrictConvert := False;
try
pOuterDynArr := PStrArr(aResult);
pOuterVarArr := PVariant(VarArrayLock(aSource));
try
for i := OuterLBound to OuterHBound do
begin
pInnerDynArr := PString(pOuterDynArr^);
pInnerVarArr := PVariant(VarArrayLock(pOuterVarArr^));
try
//System.Variants.DynArrayFromVariant(pOuterDynArr^, pInnerVarArr^, TypeInfo(String));
for j := InnerLBound to InnerHBound do
begin
pInnerDynArr^ := pInnerVarArr^; //implicit conversion to string ...
Inc(pInnerDynArr);
Inc(pInnerVarArr);
end;
finally
VarArrayUnlock(pOuterVarArr^);
end;
Inc(pOuterDynArr);
Inc(pOuterVarArr);
end;
finally
VarArrayUnlock(aSource);
end;
finally
NullStrictConvert := bVariantConversion;
end;
end;
On the other hand, if there is ever a chance that the inner arrays have different lengths, then you can try this adjustment instead:
type
TStrArr = array of string;
PStrArr = ^TStrArr;
TData = array of TStrArr;
procedure CopyResult(aResultCount: Integer; var aResult: TData; aSource: Variant);
var
i, j,
OuterLBound, OuterHBound, OuterCount,
InnerLBound, InnerHBound, InnerCount: Integer;
pOuterVarArr, pInnerVarArr: PVariant;
pOuterDynArr: PStrArr;
pInnerDynArry: PString;
bVariantConversion: boolean;
begin
aResult := nil;
Assert(VarIsType(aSource, varArray or varVariant);
Assert(VarArrayDimCount(aSource) = 1);
OuterLBound := VarArrayLowBound(aSource, 1);
OuterHBound := VarArrayHighBound(aSource, 1);
OuterCount := {aResultCount} OuterHBound - OuterLBound + 1;
if OuterCount < 1 then Exit;
SetLength(aResult, {aResultCount} OuterCount);
bVariantConversion := NullStrictConvert; // settings to manage how string conversion for Variant is handled.
NullStrictConvert := False;
try
pOuterDynArr := PStrArr(aResult);
pOuterVarArr := PVariant(VarArrayLock(aSource));
try
for i := OuterLBound to OuterHBound do
begin
pInnerVarArr := PVariant(VarArrayLock(pOuterVarArr^));
try
//System.Variants.DynArrayFromVariant(pOuterDynArr^, pInnerVarArr^, TypeInfo(String));
Assert(VarIsType(pInnerVarArr^, varArray or varVariant);
Assert(VarArrayDimCount(pInnerVarArr^) = 1);
InnerLBound := VarArrayLowBound(pInnerVarArr^, 1);
InnerHBound := VarArrayHighBound(pInnerVarArr^, 1);
InnerCount := InnerHBound - InnerLBound + 1;
SetLength(pOuterDynArr^, InnerCount);
pInnerDynArr := PString(pOuterDynArr^);
for j := InnerLBound to InnerHBound do
begin
pInnerDynArr^ := pInnerVarArr^; //implicit conversion to string ...
Inc(pInnerDynArr);
Inc(pInnerVarArr);
end;
finally
VarArrayUnlock(pOuterVarArr^);
end;
Inc(pOuterDynArr);
Inc(pOuterVarArr);
end;
finally
VarArrayUnlock(aSource);
end;
finally
NullStrictConvert := bVariantConversion;
end;
end;
Edit: I Only tested the Source version for all Entrys the same length but it works my own partial [] free Version used ~5 Million cycles with Tstopwatch ElapsedTicks and this one only took around ~2 Millon (more like 1.6) Thanks

Save array of packed record to disk

I am getting crazy.
I am trying to save an array of packed record to disk to be read later on.
The following unit contain mainly two procedures.
The first one InitSaveAndReLoad(), init a packed array of record, save it to the disk and reload from the disk in a new array of packed record and go through the loaded array and print the 20 first value. Works perfectly.
The second one LoadFromFile(), just reload the array from disk. It is even call by InitSaveAndReload() and works perfectly as soon as the file has been created previously by the same instance of the application. I mean if I quit the application and relaunch, the LoadFromFile() procedure which just reload the file in an array of records does not works anymore. I don't understand why.
Any clue?
Thanks for your help. Already spend a full day on this issue and turning crazy!
unit Unit4;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.DateUtils,
System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Menus, Vcl.StdCtrls;
type
TRate = packed record
time : int64;
open : double;
low : double;
high : double;
close : double;
tick_volume : int64;
spread : integer;
real_volume : int64;
end;
PRate = ^TRate;
TForm4 = class(TForm)
MemoLogs: TMemo;
SaveDialog1: TSaveDialog;
edFile: TEdit;
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
procedure InitSaveAndReload(Sender: TObject);
procedure Reload(Sender: TObject);
procedure SelectFile(Sender: TObject);
procedure LoadFromFile();
procedure Button4Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form4: TForm4;
implementation
{$R *.dfm}
function TimeElapsedToString(time : int64; show_ms : boolean = false) : string;
var
TmpVal:real;
TmpStr:string;
begin
TmpVal := time;
TmpStr := '';
TmpVal := TmpVal / 3600000;
TmpStr := inttostr(trunc(TmpVal));
if Length(TmpStr) = 1 then TmpStr := '0' + TmpStr;
TmpVal := (TmpVal-trunc(TmpVal))* 3600000;
TmpVal := TmpVal / 60000;
if TmpVal<10 then
TmpStr := TmpStr + ':0' + inttostr(trunc(TmpVal))
else
TmpStr := TmpStr + ':' + inttostr(trunc(TmpVal));
TmpVal := (TmpVal-trunc(TmpVal))*60000;
TmpVal := TmpVal / 1000;
if TmpVal<10 then
TmpStr := TmpStr + ':0' + inttostr(trunc(TmpVal))
else
TmpStr := TmpStr + ':' + inttostr(trunc(TmpVal));
if show_ms then
begin
TmpVal := (TmpVal-trunc(TmpVal))*1000;
TmpVal := TmpVal;
if TmpVal<10 then
TmpStr := TmpStr + ':00' + inttostr(trunc(TmpVal))
else if TmpVal<100 then
TmpStr := TmpStr + ':0' + inttostr(trunc(TmpVal))
else
TmpStr := TmpStr + ':' + inttostr(trunc(TmpVal));
end;
Result := TmpStr;
end;
procedure TForm4.SelectFile(Sender: TObject);
begin
if SaveDialog1.Execute then
edFile.Text := SaveDialog1.FileName;
end;
procedure TForm4.Button4Click(Sender: TObject);
begin
MemoLogs.Lines.Clear;
end;
procedure TForm4.InitSaveAndReload(Sender: TObject);
var
_start : TDatetime;
ARate : PRate;
filename : string;
Stream : TFileStream;
i,L : integer;
rates_M1 : array of PRate;
//rates : array of PRate;
begin
filename := edFile.Text;
MemoLogs.Lines.Add('Initialization of 7 million array of records... Please wait.');
Refresh;
// init array
_start := Now;
SetLength(rates_M1, 7000000);
for i:= 0 to 6999999 do
begin
New(ARate);
ARate.time := DateTimeToUnix(IncMinute(Now, i));
ARate.open := 1.25698;
ARate.low := 1.2574;
ARate.high := 1.2547;
ARate.close := 1.65874;
ARate.tick_volume := 154;
ARate.spread := 5;
ARate.real_volume := 15741;
rates_M1[i] := ARate;
end;
MemoLogs.Lines.Add(IntToStr(Length(rates_M1)) + ' array of records initialized ' + TimeElapsedToString(MilliSecondsBetween(Now, _start), true));
// save array
_start:= Now;
Stream:= TFileStream.Create(filename , fmCreate);
try
L:= Length(rates_M1);
Stream.WriteBuffer(L, SizeOf(L));
Stream.WriteBuffer(Pointer(rates_M1)^, L * SizeOf(ARate));
finally
Stream.Free;
MemoLogs.Lines.Add(IntToStr(Length(rates_M1)) + ' records saved to disk in ' + TimeElapsedToString(MilliSecondsBetween(Now, _start), true));
end;
LoadFromFile();
end;
procedure TForm4.LoadFromFile;
var
_start : TDatetime;
ARate : PRate;
filename : string;
Stream : TFileStream;
i,L : integer;
rates : array of PRate;
begin
// reload array
_start := Now;
filename := edFile.Text;
Stream:= TFileStream.Create(filename , fmOpenRead);
try
Stream.Read(L, SizeOf(L));
//SetLength(rates_M1, L);
// even use another empty array of ARate to be sure I am not using the same filled array!
SetLength(rates, L);
// I don't want to parse all records...
// for i := 0 to L-1 do
// begin
// Stream.Read(rates_M1[i].AID, SizeOf(ARecord.AID));
// Stream.Read(rates_M1[i].time, SizeOf(ARecord.time));
// end;
Stream.Read(Pointer(rates)^, L * SizeOf(ARate));
finally
Stream.Free;
MemoLogs.Lines.Add(IntToStr(Length(rates)) + ' records loaded from disk in ' + TimeElapsedToString(MilliSecondsBetween(Now, _start), true));
end;
// Print 20 first records just reloaded!
MemoLogs.Lines.Add('Print 20 first records just reloaded in another array of records!' + TimeElapsedToString(MilliSecondsBetween(Now, _start), true));
for i := 0 to 20 do
MemoLogs.Lines.Add('i=' + IntToStr(i) + #9
+ IntToStr(rates[i].time) + #9
+ FloatToStr(rates[i].open) + #9
);
end;
procedure TForm4.Reload(Sender: TObject);
begin
LoadFromFile();
end;
end.
Result
When I say 'Does not works anymore', I mean once you called InitSaveAndReload() procedure, you can call LoadFromFile() as many time as you want, but if you to call this procedure just after launching the app, trying to use an old file created by the InitSaveAndReload procedure, then it does not work the same!
The Unit provide is as simple as possible. Just create a new projet add 3 buttons a TMemo and one TEdit. If I could join a .rar I would have enclosed the project...
You are saving the address of each record rather than saving contents of the record. You have an array of pointers, and you save that array to file. With your current data structure you would need to save each record individually, because the actual data does not lie contiguously in memory.

How to make array distinct

I have an array of integer and string fields. To make it distinct I currently copy line by line into new array and with each record I check if the record already exists in new, if not I copy it. At the end I copy new array back to original.
It works, but is slow. Is there any faster, easier way to do this?
TArrayMixed = record
Field1: integer;
Field2: integer;
Field3: integer;
Field4: string;
Field5: string;
Field6: string;
end;
procedure TForm1.Button10Click(Sender: TObject);
var
ArrayMixed, ArrayMixed_tmp: array of TArrayMixed;
i, j, vIdx: integer;
vExists: boolean;
begin
SetLength(ArrayMixed, 100000);
for i := 0 to 99999 do
begin
ArrayMixed[i].Field1 := 1 + Random(5);
ArrayMixed[i].Field2 := 1 + Random(5);
ArrayMixed[i].Field3 := 1 + Random(5);
ArrayMixed[i].Field4 := 'String';
ArrayMixed[i].Field5 := 'Another string';
ArrayMixed[i].Field6 := 'New string';
end;
// Sort
TArray.Sort<TArrayMixed > (ArrayMixed, TComparer<TArrayMixed > .Construct(function(const Left, Right: TArrayMixed): Integer
begin
Result := MyCompareAMixed(Left, Right);
end
));
// Distinct
SetLength(ArrayMixed_tmp, Length(ArrayMixed));
vIdx := 0;
for i := Low(ArrayMixed) to High(ArrayMixed) do
begin
vExists := False;
for j := Low(ArrayMixed_tmp) to vIdx - 1 do
if (ArrayMixed_tmp[j].Field1 = ArrayMixed[i].Field1) and
(ArrayMixed_tmp[j].Field2 = ArrayMixed[i].Field2) and
(ArrayMixed_tmp[j].Field3 = ArrayMixed[i].Field3) and
(ArrayMixed_tmp[j].Field4 = ArrayMixed[i].Field4) and
(ArrayMixed_tmp[j].Field5 = ArrayMixed[i].Field5) and
(ArrayMixed_tmp[j].Field6 = ArrayMixed[i].Field6) then
begin
vExists := True;
Break;
end;
if not vExists then
begin
ArrayMixed_tmp[vIdx] := ArrayMixed[i];
Inc(vIdx);
end;
end;
SetLength(ArrayMixed_tmp, vIdx);
// now copy back to original array
SetLength(ArrayMixed, 0);
SetLength(ArrayMixed, Length(ArrayMixed_tmp));
for i := Low(ArrayMixed_tmp) to High(ArrayMixed_tmp) do
ArrayMixed[i] := ArrayMixed_tmp[i];
sleep(0);
end;
Edit:
Since in real data the strings are not all the same, the part where it makes distinct array is slower when original array is filled like this:
Edit #2: (copied wrong code in Edit #1)
for i := 0 to 999999 do
begin
ArrayMixed[i].Field1 := 1 + Random(5);
ArrayMixed[i].Field2 := 1 + Random(5);
ArrayMixed[i].Field3 := 1 + Random(5);
ArrayMixed[i].Field4 := 'String'+IntToStr(i mod 5);
ArrayMixed[i].Field5 := 'Another string'+IntToStr(i mod 5);
ArrayMixed[i].Field6 := 'New string'+IntToStr( i mod 5);
end;
Edit #3: Publishing code for sorting - only first 3 fields are sorted!
TMyArray3 = array[1..3] of Integer;
function CompareIntegerArray3(const lhs, rhs: TMyArray3): Integer;
var
i: Integer;
begin
Assert(Length(lhs) = Length(rhs));
for i := low(lhs) to high(lhs) do
if lhs[i] < rhs[i] then
exit(-1)
else if lhs[i] > rhs[i] then
exit(1);
exit(0);
end;
function GetMyArrayAMixed(const Value: TArrayMixed): TMyArray3;
begin
Result[1] := Value.Field1;
Result[2] := Value.Field2;
Result[3] := Value.Field3;
end;
function MyCompareAMixed(const lhs, rhs: TArrayMixed): Integer;
begin
Result := CompareIntegerArray3(GetMyArrayAMixed(lhs), GetMyArrayAMixed(rhs));
end;
Implement some methods (equality check, hashcode) for the record to get away with a lot of boilerplate code
type
TArrayMixed = record
Field1: integer;
Field2: integer;
Field3: integer;
Field4: string;
Field5: string;
Field6: string;
class operator Equal( const a, b: TArrayMixed ): Boolean;
class function Compare( const L, R: TArrayMixed ): integer; overload; static;
function Compare( const Other: TArrayMixed ): integer; overload;
function GetHashCode( ): integer;
end;
{ TArrayMixed }
class function TArrayMixed.Compare( const L, R: TArrayMixed ): integer;
begin
Result := L.Compare( R );
end;
function TArrayMixed.Compare( const Other: TArrayMixed ): integer;
begin
Result := Field1 - Other.Field1;
if Result = 0
then
begin
Result := Field2 - Other.Field2;
if Result = 0
then
begin
Result := Field3 - Other.Field3;
if Result = 0
then
begin
Result := CompareStr( Field4, Other.Field4 );
if Result = 0
then
begin
Result := CompareStr( Field5, Other.Field5 );
if Result = 0
then
begin
Result := CompareStr( Field6, Other.Field6 );
end;
end;
end;
end;
end;
end;
class operator TArrayMixed.Equal( const a, b: TArrayMixed ): Boolean;
begin
Result := true
{} and ( a.Field1 = b.Field1 )
{} and ( a.Field2 = b.Field2 )
{} and ( a.Field3 = b.Field3 )
{} and ( a.Field4 = b.Field4 )
{} and ( a.Field5 = b.Field5 )
{} and ( a.Field6 = b.Field6 );
end;
function TArrayMixed.GetHashCode: integer;
begin
{$IFOPT Q+}
{$Q-}
{$DEFINE SET_Q_ON}
{$ENDIF}
Result := 17;
Result := Result * 31 + Field1;
Result := Result * 31 + Field2;
Result := Result * 31 + Field3;
Result := Result * 31 + Field4.GetHashCode;
Result := Result * 31 + Field5.GetHashCode;
Result := Result * 31 + Field6.GetHashCode;
{$IFDEF SET_Q_ON}
{$Q+}
{$UNDEF SET_Q_ON}
{$ENDIF}
end;
Use a TDictionary as a HashSet to check for duplicates
procedure Test;
var
arr1, arr2: TArray<TArrayMixed>;
idx : integer;
lst : TDictionary<TArrayMixed, integer>;
begin
// fill the array
SetLength( arr1, 100000 );
for idx := low( arr1 ) to high( arr1 ) do
begin
arr1[ idx ].Field1 := 1 + Random( 5 );
arr1[ idx ].Field2 := 1 + Random( 5 );
arr1[ idx ].Field3 := 1 + Random( 5 );
arr1[ idx ].Field4 := 'String' + IntToStr( idx mod 5 );
arr1[ idx ].Field5 := 'Another string' + IntToStr( idx mod 5 );
arr1[ idx ].Field6 := 'New string' + IntToStr( idx mod 5 );
end;
// distinct
lst := TDictionary<TArrayMixed, integer>.Create( TEqualityComparer<TArrayMixed>.Construct(
function( const L, R: TArrayMixed ): Boolean
begin
Result := ( L = R );
end,
function( const i: TArrayMixed ): integer
begin
Result := i.GetHashCode( );
end ) );
try
for idx := low( arr1 ) to high( arr1 ) do
begin
lst.AddOrSetValue( arr1[ idx ], 0 );
end;
arr2 := lst.Keys.ToArray;
finally
lst.Free;
end;
end;
I would do something like this. You basically create the result on the fly and sort at the same time using a binary search to remove the duplicates.
function RemoveDuplicates(aSourceArray: TArray<TArrayMixed>): TArray<TArrayMixed>;
var
i: Integer;
index: Integer;
sortList: TList<TArrayMixed>;
begin
sortList := TList<TArrayMixed>.Create;
try
for i := Low(aSourceArray) to High(aSourceArray) do
begin
if not sortList.BinarySearch(aSourceArray[i], index,
TDelegatedComparer<TArrayMixed>.Construct(
function(const L, R: TArrayMixed): integer
begin
Result := L.Field1 - R.Field1;
if Result <> 0 then Exit;
Result := L.Field2 - R.Field2;
if Result <> 0 then Exit;
Result := L.Field3 - R.Field3;
if Result <> 0 then Exit;
Result := CompareStr(L.Field4, R.Field4);
if Result <> 0 then Exit;
Result := CompareStr(L.Field5, R.Field5);
if Result <> 0 then Exit;
Result := CompareStr(L.Field6, R.Field6);
end)) then
begin
sortList.Insert(index, aSourceArray[i]);
end;
end;
Result := sortList.ToArray;
finally
sortList.Free;
end;
end;
To use this code you could do something like this:
procedure TForm1.Button10Click(Sender: TObject);
var
ArrayMixed, ArrayMixed_tmp: TArray<TArrayMixed>;
i: Integer;
begin
SetLength(ArrayMixed, 100000);
for i := 0 to 999999 do
begin
ArrayMixed[i].Field1 := 1 + Random(5);
ArrayMixed[i].Field2 := 1 + Random(5);
ArrayMixed[i].Field3 := 1 + Random(5);
ArrayMixed[i].Field4 := 'String'+IntToStr(i mod 5);
ArrayMixed[i].Field5 := 'Another string'+IntToStr(i mod 5);
ArrayMixed[i].Field6 := 'New string'+IntToStr( i mod 5);
end;
ArrayMixed_tmp := RemoveDuplicates(ArrayMixed);
end;
Just check for duplicates next to the prior index, since the array is sorted. Here is the sorting comparer reused as well.
function RemoveDuplicates(const anArray: array of TArrayMixed): TArray<TArrayMixed>;
var
j, vIdx: integer;
begin
// Sort
TArray.Sort<TArrayMixed > (anArray, TComparer<TArrayMixed >.Construct(function(const Left, Right: TArrayMixed): Integer
begin
Result := MyCompareAMixed(Left, Right);
end
));
// Distinct
SetLength(Result, Length(anArray));
vIdx := 0;
j := 0;
while (j <= High(anArray) do
begin
Result[vIdx] := anArray[j];
Inc(j);
While (j <= High(anArray)) and (MyCompareAMixed(Result[vIdx],anArray[j]) = 0) do
Inc(j);
Inc(vIdx);
end;
SetLength(Result, vIdx);
end;
Update:
In an update to the question it is stated that the array is only partially sorted. One way to reduce the number of iterations to remove duplicates would then be to:
Find start and stop index to items that share the first sorting criteria.
Iterate among them to sort out duplicates.
Since you already sort ArrayMixed you don't need to compare each item with each other in order to find duplicates. The duplicates are already placed next to each other. So you simply need to iterate over ArrayMixed and compare the current item to the last item in ArrayMixed_tmp.
Hence, copying the distinct items can be proceed much faster and looks like that:
vIdx := 0;
for i := Low(ArrayMixed) to High(ArrayMixed) do
begin
if (vIdx = 0) or // the first item can never be a duplicate
(ArrayMixed_tmp[vIdx].Field1 <> ArrayMixed[i].Field1) or
(ArrayMixed_tmp[vIdx].Field2 <> ArrayMixed[i].Field2) or
(ArrayMixed_tmp[vIdx].Field3 <> ArrayMixed[i].Field3) or
(ArrayMixed_tmp[vIdx].Field4 <> ArrayMixed[i].Field4) or
(ArrayMixed_tmp[vIdx].Field5 <> ArrayMixed[i].Field5) or
(ArrayMixed_tmp[vIdx].Field6 <> ArrayMixed[i].Field6) then
begin
ArrayMixed_tmp[vIdx] := ArrayMixed[i];
Inc(vIdx);
end;
end;
You have not posted the code for your MyCompareAMixed() function so it is not possible to test the performance of your actual code including this undefined function, including the current sort performance.
However, since your posted duplicate detection approach is not dependent upon the array being sorted I simply removed the sort from the code.
Without any further optimisation the resulting de-duplication process completed in well under 50 msecs, which is not "slow" in my book for de-duping 100,000 complex items. i.e. not single values but items that are records of multiple values.
If the sort is necessary for other reasons then you could retain the sorting and optimise the de-dupe process based on the answers given by others, but I would first question why you think the process is slow and if sub 50 msecs really is slow, what is the target you are aiming at ?
It is possible that it is the sorting that is adding the overhead (as I say, without your compare function we cannot quantify the overhead this is adding) so if this sorting is not necessary for other reasons and if sub 50-msecs is acceptable for de-duping this array, then I would move on to other tasks.

Initiating a SOAP Array on Delphi

I am trying to initialize or create an array of a soap call:
Array_Of_ProductIdentifierClinicalType = array of ProductIdentifierClinicalType;
This is the way that I am trying to initialize it:
Product[0].IdentifierType := Array_Of_ProductIdentifierClinicalType.Create();
When I run the application I get this error: Access Violation at address...
The question would be: How to initialize this soap call??
Thank you for your time!!!!
You can do a WSDL import on: http://axelcarreras.dyndns.biz:3434/WSAlchemy.wsdl
procedure TFrmMain.Button16Click(Sender: TObject);
Var
ExcludeExpiradas: String;
Serv: AlchemyServiceSoap;
req: AlchemyClinical;
element: AlchemyClinicalRequest;
Prescribed: PrescribedType;
//Prescribing: Prescribing
Prescribing: PrescribedType;
alc: AlchemyIdentifierType;
D: TXSDate;
Counter: Integer;
ProductStr: AlchemyIdentifierClinicalType;
begin
With DM do
begin
ExcludeExpiradas := ' and (' + chr(39) + DateToStr(Date) + chr(39) + ' < (FECHARECETA + 180)) ';
CDSRx_Procesadas.Close;
CDSRx_Procesadas.CommandText := 'SELECT * ' +
' FROM RX_PROCESADAS WHERE ' +
' (NUMERORECETA IS NOT NULL AND CANTIDAD_DISPONIBLE > 0)' +
ExcludeExpiradas +
' and NumeroCliente = ' + CDSPacientesNumeroCliente.asString +
' Order by NumeroReceta';
//ShowMessage(CDSRx_Procesadas.CommandText);
CDSRx_Procesadas.Open;
ProductStr := AlchemyIdentifierClinicalType.Create;
With ProductStr do
begin
Identifier := 1;
end;
element := AlchemyClinicalRequest.Create;
//Prescribed := PrescribedType.Create;
With element do
begin
With Prescribed do
begin
Counter := 0;
while not CDSRx_Procesadas.eof do
begin
Product := Array_Of_ProductIdentifierClinicalType.Create();
With Product[0] do
begin
IdentifierType := ProductIdentifierTypeEnum.NDC9;
Identifier := Copy(DM.CDSInventarioNDC.Value, 1, 9);
end;
Counter := Counter + 1;
CDSRx_Procesadas.Next;
end;
end;
With Prescribing do
begin
Counter := 0;
Product[0].IdentifierType := ProductIdentifierTypeEnum.AlchemyProductID;
Product[0].Identifier := Copy(DM.CDSInventarioNDC.Value, 1, 9);
Counter := Counter + 1;
end;
With PatientDemographics do
begin
while not CDSAlergies.Eof do
begin
Allergy.AllergySubstanceClass[0].Identifier := CDSAlergiesNOALERGIA.Value;
CDSAlergies.Next;
end;
if CDSPacientesSEXO.Value = 1 then
Gender := GenderTypeEnum.Male
else
Gender := GenderTypeEnum.Female;
D := TXSDate.Create;
D.AsDate := CDSPacientesFECHANACIMIENTO.AsDateTime;
DateOfBirth := D;
end;
With RequestedOperations do
begin
DrugToDrug := True;
//DuplicateTherapy
Allergy := True;
With WarningLabels do
begin
Request := True;
LanguageCode := 'en-US';
MaxLines := 5;
CharsPerLine := 24;
end;
With DoseScreening do
begin
Request := True;
end;
AdverseReactions.Request := True;
end;
IgnorePrescribed := False;
IncludeConsumerNotes := True;
IncludeProfessionalNotes := True;
end;
end;
end;*
Assuming that this line of code from the question is accurate:
Array_Of_ProductIdentifierClinicalType = array of ProductIdentifierClinicalType;
then the problem lies here:
Product := Array_Of_ProductIdentifierClinicalType.Create();
This is a dynamic array constructor. It creates a dynamic array of length equal to the number of parameters to the constructor. And then assigns each element of the array, in turn, to the parameters passed.
Consider an example using TBytes = array of Byte.
Bytes := TBytes.Create(1, 2, 3);
This initialises Bytes to be an array of length 3 and having values 1, 2 and 3.
Now, let's look at your code again. This initialises Product to be an array of length 0. So when you access Product[0] that results in a runtime error because the array index is out of bounds.
To solve the problem you will need to make sure that the array is initialised to have sufficient elements. One option is certainly to use a dynamic array constructor. Another is to use SetLength. I suspect that your understanding of Delphi's dynamic arrays is poor. I suggest that you consult the documentation.

Resources