Dict vs SortAndSearch

program Project28;

{$APPTYPE CONSOLE}

uses SysUtils, Windows, Generics.Collections;

type TFindDup = function: Integer;

function TimeProc(Proc: TProcedure): Int64;
var EndCount: Int64;
begin
  QueryPerformanceCounter(Result);
  Proc;
  QueryPerformanceCounter(EndCount);
  Result := EndCount - Result;
end;

var WorkArray: TArray<string>;

function SortAndScan:Integer;
var i: Integer;
    prevstr, cstr: string;
begin
  TArray.Sort<string>(WorkArray);
  prevstr := WorkArray[0];
  for i:=1 to High(WorkArray) do
  begin
    cstr := WorkArray[i];
    if cstr = prevstr then
      Exit(-1);
    prevstr := cstr;
  end;
  Result := -1;
end;

type TZeroWidthRecord = record end;
function TestUsingDict:Integer;
var D: TDictionary<string, TZeroWidthRecord>;
    i: Integer;
    s: string;
    ZW: TZeroWidthRecord;
begin
  D := TDictionary<string, TZeroWidthRecord>.Create(Length(WorkArray));
  try
    for i:=0 to High(WorkArray) do
    begin
      s := WorkArray[i];
      try
        D.Add(s, ZW);
      except on E:Exception do
        Exit(i);
      end;
    end;
  finally D.Free;
  end;
  Result := -1;
end;

function TestNumberOfStrings(const Cnt, MaxWordCount:Integer): Boolean; // Returns TRUE if the dictionary was 25% faster then the sort-and-scan
var Total_Sort: Int64;
    Total_Dict: Int64;
    i,j,k: Integer;
    TestArray: TArray<string>;
    UniqueDict: TDictionary<string, TZeroWidthRecord>;
    WordCount: Integer;
    s: string;
    ZW: TZeroWidthRecord;
    TotalStrLen, AvgStrLen: Integer;
const distinct_arrays = 5;
      pass_per_array = 5;
      WordList:array[0..142] of string =
        (
          'test', 'find', 'duplicate', 'speed', 'for', 'using', 'a', 'number', 'of', 'separate',
          'algorithms', 'designed', 'to', 'investigate', 'how', 'efficient', 'tdictionary',
          'really', 'is',
          'In', 'computing', 'a', 'hash', 'table', 'also', 'hash', 'map', 'is', 'a', 'data', 'structure',
          'used', 'to', 'implement', 'an', 'associative', 'array', 'a', 'structure', 'that', 'can', 'map',
          'keys', 'to', 'values', 'A', 'hash', 'table', 'uses', 'a', 'hash', 'function', 'to', 'compute', 'an',
          'index', 'into', 'an', 'array', 'of', 'buckets', 'or', 'slots', 'from', 'which', 'the', 'correct', 'value', 'can', 'be', 'found',
          'Ideally', 'the', 'hash', 'function', 'should', 'assign', 'each', 'possible', 'key', 'to', 'a', 'unique', 'bucket',
          'but', 'this', 'ideal', 'situation', 'is', 'rarely', 'achievable', 'in', 'practice', 'unless', 'the', 'hash', 'keys',
          'are', 'fixed', 'i.e.', 'new', 'entries', 'are', 'never', 'added', 'to', 'the', 'table', 'after', 'it', 'is', 'created',
          'Instead', 'most', 'hash', 'table', 'designs', 'assume', 'that', 'hash', 'collisions', 'different', 'keys',
          'that', 'are', 'assigned', 'by', 'the', 'hash', 'function', 'to', 'the', 'same', 'bucket', 'will', 'occur', 'and', 'must', 'be', 'accommodated', 'in', 'some', 'way'
        );
begin
  WriteLn('Testing with ', Cnt, ' strings.');
  Total_Sort := 0;
  Total_Dict := 0;

  SetLength(TestArray, Cnt);
  SetLength(WorkArray, Cnt);

  TotalStrLen := 0;
  for i:=1 to distinct_arrays do
  begin
    UniqueDict := TDictionary<string, TZeroWidthRecord>.Create;
    try
      for j:=0 to Cnt-1 do
      begin
        repeat
          WordCount := Random(MaxWordCount);
          s := '';
          if WordCount > 0 then
          begin
            s := WordList[Random(High(WordList))];
            for k:=2 to WordCount do
              s := s + ' ' + WordList[Random(High(WordList))];
          end;
        until not UniqueDict.ContainsKey(s);

        UniqueDict.Add(s, ZW);
        TestArray[j] := s;
        Inc(TotalStrLen, Length(s));

      end;

      // Make sure the array contains a duplicate:
      // TestArray[Cnt div 4] := TestArray[0];

    finally UniqueDict.Free;
    end;

    for k:=0 to High(WorkArray) do WorkArray[k] := TestArray[k];
    for j:=1 to pass_per_array do
    begin
      Total_Dict := Total_Dict + TimeProc(@TestUsingDict);
    end;

    for j:=1 to pass_per_array do
    begin
      for k:=0 to High(WorkArray) do WorkArray[k] := TestArray[k];
      Total_Sort := Total_Sort + TimeProc(@SortAndScan);
    end;
  end;

  AvgStrLen := TotalStrLen div (Cnt * distinct_arrays);
  if Total_Dict < Total_Sort then
    begin
      Result := True;
      s := 'Dict was ' + IntToStr(100 - (Total_Dict * 100) div Total_Sort) + '% faster';
    end
  else
    begin
      Result := False;
      s := 'Sort was ' + IntToStr(100 - (Total_Sort * 100) div Total_Dict) + '% faster';
    end;
  WriteLn(': Dict=', Total_Dict, '; Sort=', Total_Sort, ';AvgStrLen=', AvgStrLen, ': ', s);
end;

var WordCount: Integer;
    N: Integer;

begin
  try
    Randomize;

    for WordCount := 11 to 20 do
    begin
      WriteLn('Testing with MaxWordCount=', WordCount);
      N := 5;
      while (N < 200000) and not TestNumberOfStrings(N, WordCount) do
      begin
        N := (N * 3) div 2;
      end;
      WriteLn;
      WriteLn;
    end;

    ReadLn;
  except
    on E: Exception do Writeln(E.ClassName, ': ', E.Message);
  end;
end.