Sampler: Generic enumerators for generic containers

unit Unit1; 

{ (c) 2010 bflm, contact: befelemepeseveze at Google's free mail

  Free sample code - copy, use, modify, distribute, sell, release under other license, ...

}

{$mode objfpc}{$H+}

interface

type

  { TEnumerator }

  generic TEnumerator<TValue, TIterator> = object
  public type
    TGetCurrent = function(const Iterator: TIterator): TValue of object;
    TMoveNext = function(var Iterator: TIterator): Boolean of object;
  private var
    FGetCurrent: TGetCurrent;
    FMoveNext: TMoveNext;
    FIterator: TIterator;
    function GetCurrent: TValue;
  public
    procedure Init(const InitialIterator: TIterator; const Mover: TMoveNext; const Getter: TGetCurrent);
    function MoveNext: Boolean;
    property Current: TValue read GetCurrent;
  end;

  { TVector }

  generic TVector<T> = object
  public type
    TData = array of T;
    TCompare = function(const A, B: T): Integer;
    TVectorEnumerator = specialize TEnumerator<T, Integer>;
  private var
    FData: TData;
    FLen: Integer;
  private
    function GetCap: Integer;
    function GetData: TData;
    function GetItems(const Index: Integer): T; inline;
    function GetLen: Integer; inline;
    function MoveNext(var Index: Integer): Boolean;
    procedure Sort(Left, Right: Integer; const Compare: TCompare);
    procedure SetCap(const AValue: Integer);
    procedure SetData(const AValue: TData);
    procedure SetItems(const Index: Integer; const AValue: T); inline;
    procedure SetLen(const AValue: Integer);
  public
    function GetEnumerator: TVectorEnumerator;
    function Add(const Value: T): Integer;
    procedure Clear;
    procedure Pack;
    procedure Sort(const Compare: TCompare);
    property Cap: Integer read GetCap write SetCap;
    property Data: TData read GetData write SetData;
    property Items[const Index: Integer]: T read GetItems write SetItems; default;
    property Len: Integer read GetLen write SetLen;
  end;

implementation

{ TEnumerator }

function TEnumerator.GetCurrent: TValue;
begin
  Result := FGetCurrent(FIterator);
end;

function TEnumerator.MoveNext: Boolean;
begin
  Result := FMoveNext(FIterator);
end;

procedure TEnumerator.Init(const InitialIterator: TIterator; const Mover: TMoveNext; const Getter: TGetCurrent);
begin
  Assert(Assigned(Mover));
  Assert(Assigned(Getter));
  FIterator := InitialIterator;
  FMoveNext := Mover;
  FGetCurrent := Getter;
end;

{ TVector }

function TVector.Add(const Value: T): Integer;
var NeedCap: Integer;
begin
  NeedCap := Len + 1;
  if NeedCap > Cap then
    Cap := 2 * NeedCap;
  Result := FLen;
  Inc(FLen);
  Items[Result] := Value;
end;

procedure TVector.Clear;
begin
  Cap := 0;
end;

function TVector.GetItems(const Index: Integer): T;
begin
  Result := FData[Index];
end;

function TVector.GetCap: Integer;
begin
  Result := Length(FData);
end;

function TVector.GetData: TData;
begin
  Result := Copy(FData, 0, Len);
end;

function TVector.GetEnumerator: TVectorEnumerator;
begin
  Result.Init(-1, @MoveNext, @GetItems);
end;

function TVector.GetLen: Integer;
begin
  if FData = nil then
    FLen := 0; // boot
  Result := FLen;
end;

function TVector.MoveNext(var Index: Integer): Boolean;
begin
  Result := Index + 1 < Len;
  if Result then
    Inc(Index);
end;

procedure TVector.SetCap(const AValue: Integer);
begin
  if AValue = Cap then
    Exit;
  if Len > AValue then
    FLen := AValue;
  SetLength(FData, AValue);
end;

procedure TVector.SetData(const AValue: TData);
begin
  FData := AValue;
  FLen := Cap;
end;

procedure TVector.SetItems(const Index: Integer; const AValue: T);
begin
  FData[Index] := AValue;
end;

procedure TVector.SetLen(const AValue: Integer);
begin
  if AValue = Len then
    Exit;
  if AValue > Cap then
    Cap := AValue
  else if AValue <= Cap div 2 then
    Cap := Cap div 2;
  FLen := AValue;
end;

procedure TVector.Sort(Left, Right: Integer; const Compare: TCompare);
var
  L, R: Integer;
  Pivot, Swap: T;
begin
 repeat
   L := Left;
   R := Right;
   Pivot := Items[(Left + Right) div 2];
   repeat
     while Compare(Pivot, Items[L]) > 0 do
       L += 1;
     while Compare(Pivot, Items[R]) < 0 do
       R -= 1;
     if L <= R then begin
       Swap := Items[L];
       Items[L] := Items[R];
       Items[R] := Swap;
       L += 1;
       R -= 1;
     end;
   until L > R;
   if Left < R then
     Sort(Left, R, Compare);
   Left := L;
 until L >= Right;
end;

procedure TVector.Pack;
begin
  Cap := Len;
end;

procedure TVector.Sort(const Compare: TCompare);
begin
  if Len > 1 then
    Sort(0, FLen - 1, Compare);
end;

end.

program project1;

{$mode objfpc}{$H+}

uses Unit1;

type
  TIntVector = specialize TVector<Integer>;

function IntCmp(const A, B: Integer): Integer;
begin
  Result := A - B;
end;

procedure Dump(const Vector: TIntVector);
var V: Integer;
begin
  Write(Vector.Len, ' item(s): ');
  for V in Vector do
    Write(V, ' ');
  Writeln;
end;

procedure Test(const N, X: Integer);
var
  Vector: TIntVector;
  I: Integer;
begin
  for I := 1 to N do
    Vector.Add(I xor X);
  Dump(Vector);
  Vector.Sort(@IntCmp);
  Dump(Vector);
  WriteLn;
end;

begin // main
  {$if declared(HaltOnNotReleased)}
  HaltOnNotReleased := True;
  {$endif}
  Test(0, 0);
  Test(1, 0);
  Test(11, 0);
  Test(13, $55);
  Test(17, $AA);
  Test(19, $FF);
end.

$ fpc -B -gh project1 && ./project1 
Free Pascal Compiler version 2.5.1 [2010/05/05] for x86_64
Copyright (c) 1993-2009 by Florian Klaempfl
Target OS: Linux for x86-64
Compiling project1.pas
Compiling unit1.pas
Linking project1
/usr/bin/ld: warning: link.res contains output sections; did you forget -T?
259 lines compiled, 0.1 sec 
0 item(s): 
0 item(s): 

1 item(s): 1 
1 item(s): 1 

11 item(s): 1 2 3 4 5 6 7 8 9 10 11 
11 item(s): 1 2 3 4 5 6 7 8 9 10 11 

13 item(s): 84 87 86 81 80 83 82 93 92 95 94 89 88 
13 item(s): 80 81 82 83 84 86 87 88 89 92 93 94 95 

17 item(s): 171 168 169 174 175 172 173 162 163 160 161 166 167 164 165 186 187 
17 item(s): 160 161 162 163 164 165 166 167 168 169 171 172 173 174 175 186 187 

19 item(s): 254 253 252 251 250 249 248 247 246 245 244 243 242 241 240 239 238 237 236 
19 item(s): 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 

Heap dump by heaptrc unit
11 memory blocks allocated : 840/840
11 memory blocks freed     : 840/840
0 unfreed memory blocks : 0
True heap size : 98304
True free heap : 98304
$