Recent

Author Topic: Generic array of records with sorting and such?  (Read 1729 times)

domasz

  • Sr. Member
  • ****
  • Posts: 275
Generic array of records with sorting and such?
« on: June 09, 2023, 03:46:16 pm »
Is there a generic that can be an array of record but with sorting by data?

I tried:
Code: Pascal  [Select][+][-]
  1. TMyFiles = specialize TFPGMap<Integer, TMyFileRec>;
but it can only sort by key (Integer) using whatever I hook to OnKeyCompare.

Thaddy

  • Hero Member
  • *****
  • Posts: 13210
Re: Generic array of records with sorting and such?
« Reply #1 on: June 09, 2023, 04:41:59 pm »
generics.collections can do that
I actually get compliments for being rude... (well, Dutch, but that is the same)

paweld

  • Hero Member
  • *****
  • Posts: 789
Best regards / Pozdrawiam
paweld

domasz

  • Sr. Member
  • ****
  • Posts: 275
Re: Generic array of records with sorting and such?
« Reply #3 on: June 10, 2023, 06:26:29 pm »
Thank you!

I didn't find anything that would work exactly like I wanted so I made my own.
Usage example:
Code: Pascal  [Select][+][-]
  1.   TRec = record
  2.     Name: String;
  3.     Surname: String;
  4.   end;
  5.  
  6.   TArr = specialize TSortable<TRec>;
  7.  
  8. ...
  9. function CompareFun(const Data1, Data2: TRec): Integer;
  10. begin
  11.   Result := AnsiCompareStr(Data1.Name, Data2.Name);
  12. end;    
  13.  
  14. var Arr: TArr;
  15.     Rec: TRec;
  16.     i: Integer;
  17.     Idx: Integer;
  18. begin
  19.   Arr := TArr.Create;
  20.  
  21.   Rec.Name := 'John';
  22.   Rec.Surname := 'Kowalski';
  23.  
  24.   Arr.Add(Rec);
  25.  
  26.   Rec.Name := 'Adam';
  27.   Rec.Surname := 'Smith';
  28.  
  29.   Arr.Add(Rec);
  30.  
  31.   Arr.Sort(@CompareFun);
  32.  
  33.   for i:=0 to Arr.Count-1 do
  34.     Memo1.Lines.Add(Arr[i].Name + ' ' + Arr[i].Surname);
  35.  
  36.   Rec.Name := 'Adama';
  37.   Rec.Surname := 'Worcestershire';
  38.  
  39.   Idx := Arr.IndexOf(Rec, @CompareFun);
  40.  
  41.   Memo1.Lines.Add(IntToStr(Idx));
  42.  
  43.   Arr.Free;                                            
  44.  

Code: [Select]
unit Sortable;

{$mode objfpc}{$H+}

interface

//Sortable- a nice array for records by domasz

uses
  Classes, SysUtils, StdCtrls, FGL, Types, Dialogs, Generics.Collections, Generics.Defaults;

type

  { TSortable }

  generic TSortable<TData> = class
  private
    type TCompareFun = function(const Data1, Data2: TData): Integer;
  private
    FItems: array of TData;
    FMaxSize: Integer;
    FSize: Integer;
    FSorted: Boolean;
    procedure SetItem(Index: Integer; Value: TData);
    function GetItem(Index: Integer): TData;
    procedure Grow;
    function BinSearch(Data: TData; CompareFun: TCompareFun): Integer;
  public
    constructor Create;
    property Count: Integer read FSize;
    property Items[Index: Integer]: TData read GetItem write SetItem; default;
    procedure Add(Value: TData);
    procedure Delete(Index: Integer);
    procedure Sort(CompareFun: TCompareFun);
    procedure Clear;
    function IndexOf(Data: TData; CompareFun: TCompareFun): Integer;
    procedure Optimize;
  end;

implementation

{ TSortable }

procedure TSortable.SetItem(Index: Integer; Value: TData);
begin
  if (Index<0) or (Index>FSize-1) then Exception.Create('Index out of bounds');

  FItems[Index] := Value;
end;

function TSortable.GetItem(Index: Integer): TData;
begin
  if (Index<0) or (Index>FSize-1) then Exception.Create('Index out of bounds');

  Result := FItems[Index];
end;

procedure TSortable.Grow;
begin
  Inc(FMaxSize, 100);
  SetLength(FItems, FMaxSize);
end;

function TSortable.BinSearch(Data: TData; CompareFun: TCompareFun): Integer;
var Left, Right: Integer;
    Cur: TData;
    i: Integer;
    Found: Boolean;
    SameRes: Integer;
begin
  Found := false;
  Result := -1;
  if FSize = 0 then Exit;

  Left := 0;
  Right := FSize-1;

  while ((CompareFun(FItems[Left], FItems[Right]) <= 0) and (Found = false)) do begin
    i := Left + ((Right - Left) div 2);
    Cur := FItems[i];

    SameRes := CompareFun(Data, Cur);

    if SameRes = 0 then begin
      Result := i;
      Found := True;
    end
    else if SameRes > 0 then Left := i + 1
    else Right := i - 1;
  end;
end;

constructor TSortable.Create;
begin
  inherited Create;
  FMaxSize := 100;
  FSize := 0;
  FSorted := True;
  SetLength(FItems, FMaxSize);
end;

procedure TSortable.Add(Value: TData);
begin
  if FSize = FMaxSize then Grow;

  FItems[FSize] := Value;
  Inc(FSize);
  FSorted := False;
end;

procedure TSortable.Delete(Index: Integer);
var i: Integer;
begin
  if (Index<0) or (Index>FSize-1) then Exception.Create('Index out of bounds');

  for i:=Index to FSize-3 do
    FItems[i] := FItems[i+1];

  Dec(FSize);
end;

procedure TSortable.Sort(CompareFun: TCompareFun);
  procedure QSort(ALo, AHi: Integer);
  var Lo, Hi: Integer;
      Pivot, Temp: TData;
  begin
    Lo := ALo;
    Hi := AHi;
    Pivot := FItems[(Lo + Hi) div 2];
    repeat
      while CompareFun(FItems[Lo], Pivot) < 0 do Inc(Lo);
      while CompareFun(FItems[Hi], Pivot) > 0 do Dec(Hi);

      if Lo <= Hi then begin
        Temp := FItems[Lo];
        FItems[Lo] := FItems[Hi];
        FItems[Hi] := Temp;
        Inc(Lo) ;
        Dec(Hi) ;
      end;
    until Lo > Hi;
    if Hi > ALo then QSort(ALo, Hi) ;
    if Lo < AHi then QSort(Lo, AHi) ;
  end;

begin
  QSort(0, FSize-1);
  FSorted := True;
end;

procedure TSortable.Clear;
begin
  FSize := 0;
end;

function TSortable.IndexOf(Data: TData; CompareFun: TCompareFun): Integer;
var i: Integer;
begin
  if FSorted then begin
    Result := BinSearch(Data, CompareFun);
    Exit;
  end;

  Result := -1;

  for i:=0 to FSize-1 do
    if CompareFun(FItems[i], Data) = 0 then begin
      Result := i;
      Exit;
    end;
end;

procedure TSortable.Optimize;
begin
  FMaxSize := FSize;
  SetLength(FItems, FSize);
end;

end.
« Last Edit: June 10, 2023, 06:29:14 pm by domasz »

Warfley

  • Hero Member
  • *****
  • Posts: 1429
Re: Generic array of records with sorting and such?
« Reply #4 on: June 10, 2023, 09:44:08 pm »
Have you tried gmap or gset: https://wiki.freepascal.org/GSet

domasz

  • Sr. Member
  • ****
  • Posts: 275
Re: Generic array of records with sorting and such?
« Reply #5 on: June 12, 2023, 12:36:54 pm »
I don't think I can quickly access n-th element using TSet.

ASerge

  • Hero Member
  • *****
  • Posts: 2102
Re: Generic array of records with sorting and such?
« Reply #6 on: June 12, 2023, 06:00:08 pm »
Is there a generic that can be an array of record but with sorting by data?
Code: Pascal  [Select][+][-]
  1. {$MODE OBJFPC}
  2. {$APPTYPE CONSOLE}
  3. {$LONGSTRINGS ON}
  4. {$MODESWITCH ADVANCEDRECORDS}
  5.  
  6. uses SysUtils, Generics.Defaults, Generics.Collections;
  7.  
  8. type
  9.   TRec = record
  10.     Name: string;
  11.     Surname: string;
  12.     constructor Create(const AName, ASurname: string);
  13.   end;
  14.  
  15.   TList = specialize TSortedList<TRec>;
  16.  
  17. constructor TRec.Create(const AName, ASurname: string);
  18. begin
  19.   Name := AName;
  20.   Surname := ASurname;
  21. end;
  22.  
  23. function CompareRec(constref R1, R2: TRec): Integer;
  24. begin
  25.   Result := AnsiCompareText(R1.Name, R2.Name);
  26.   if Result = 0 then
  27.     Result := AnsiCompareText(R1.Surname, R2.Surname);
  28. end;
  29.  
  30. var
  31.   List: TList;
  32.   R: TRec;
  33. begin
  34.   List := TList.Create((specialize TComparer<TRec>).Construct(@CompareRec));
  35.   try
  36.     List.Add(TRec.Create('John', 'Kowalski'));
  37.     List.Add(TRec.Create('Adam', 'Smith'));
  38.     List.Add(TRec.Create('Bill', 'Smith'));
  39.     for R in List do
  40.       Writeln('Name: ', R.Name, ', Surname: ', R.Surname);
  41.   finally
  42.     List.Free;
  43.   end;
  44.   Readln;
  45. end.

marcov

  • Administrator
  • Hero Member
  • *
  • Posts: 10936
  • FPC developer.
Re: Generic array of records with sorting and such?
« Reply #7 on: June 12, 2023, 06:37:36 pm »
Generics.collections.TarrayHelper.sort<>

 

TinyPortal © 2005-2018