program project1;
uses
sysutils, fgl;
type
TItem = class
s:string;
p:integer;
q:integer;
procedure SetItem(f1:string;f2:integer;f3:integer);
procedure ShowItem;
end;
TObjectList = specialize TFPGObjectList<TItem>;
TObjectListHelper = class helper for TObjectList
function IndexOf(AItem: TItem): Integer; overload;
function IndexOf(AItem: string) : Integer; overload;
function IndexOf(AItem: integer) : Integer; overload;
end;
procedure TItem.SetItem(f1:string;f2:integer;f3:integer);
begin
s:=f1;
p:=f2;
q:=f3;
end;
procedure TItem.ShowItem;
begin
writeln(s:12, p:4, q:4);
end;
function TObjectListHelper.IndexOf(AItem: TItem) : Integer; overload;
var
i: Integer;
item: TItem;
begin
result := -1;
for i := 0 to Pred(Self.Count) do
begin
item := Self[i];
if (item.p <> AItem.p) or (item.q <> AItem.q) then
Continue;
// use CompareStr if you want case sensitivity
if CompareText(item.s, AItem.s)=0 then
Exit(i);
end;
end;
function TObjectListHelper.IndexOf(AItem:string) : Integer; overload;
var
i: Integer;
item: TItem;
begin
result := -1;
for i := 0 to Pred(Self.Count) do
begin
item := Self[i];
if CompareText(item.s, AItem)=0 then
begin
Exit(i);
end;
end;
end;
function TObjectListHelper.IndexOf(AItem: integer) : Integer; overload;
var
i: Integer;
item: TItem;
begin
result := -1;
for i := 0 to Pred(Self.Count) do
begin
item := Self[i];
if (item.p = AItem) or (item.q = AItem) then
begin
Exit(i);
end;
end;
end;
var
A:TObjectList;
B:TItem;
procedure ShowTitle(Message:string);
begin
writeln;
writeln(Message);
writeln('--------------------------');
end;
procedure ShowObject(Z:TObjectList; k:integer);
begin
If k <> -1 then
begin
writeln(k:4, Z[k].s:12, Z[k].p:4, Z[k].q:4);
end;
end;
procedure ShowObjectList(Z:TObjectList);
var
k:integer;
begin
For k:= 0 to Z.count-1 do
begin
writeln(k:4, Z[k].s:12, Z[k].p:4, Z[k].q:4);
end;
writeln;
end;
function compare1(const a, b: TItem): Integer;
begin
If a.s > b.s then
Result := 1;
If a.s = b.s then
Result := 0;
If a.s < b.s then
Result := -1;
end;
function compare2(const a, b: TItem): Integer;
begin
Result := a.p - b.p;
end;
function compare3(const a, b: TItem): Integer;
begin
Result := a.q - b.q;
end;
begin
ShowTitle('TFPGObjectList');
A:=TObjectList.create;
A.FreeObjects:=False;
ShowTitle('Adding objects');
B:=TItem.create;
B.SetItem('Lazarus',3,7);
A.Add(B);
B:=TItem.create;
B.SetItem('Python',8,5);
A.Add(B);
B:=TItem.create;
B.SetItem('Free Pascal',3,10);
A.Add(B);
B:=TItem.create;
B.SetItem('Visual Basic',5,11);
A.Add(B);
writeln('Index of B is ',A.IndexOf(B));
ShowTitle('Sort by column 1');
A.Sort(@Compare1);
ShowObjectList(A);
writeln(A.Count);
ShowTitle('Sort by column 2');
A.Sort(@Compare2);
ShowObjectList(A);
writeln(A.Count);
ShowTitle('Sort by column 3');
A.Sort(@Compare3);
ShowObjectList(A);
writeln(A.Count);
ShowTitle('Find the index given a complete item');
B:=TItem.create;
B.SetItem('Lazarus',3,7);
writeln('Index of Lazarus is : ',A.IndexOf(B));
ShowObject(A, A.IndexOf(B));
ShowTitle('Find the index given the key value string');
writeln('Index of Free Pascal is : ',A.IndexOf('Free Pascal'));
ShowObject(A, A.IndexOf('Free Pascal'));
ShowTitle('Find the index given a non-key value 10');
writeln('Index of 10 is : ',A.IndexOf(10));
ShowObject(A, A.IndexOf(10));
ShowTitle('Find the index given a non-key value 3');
writeln('Index of 3 is : ',A.IndexOf(3));
ShowObject(A, A.IndexOf(3));
B.free;
A.free;
writeln('---done----');
readln;
end.