Reading FAST from a HUDGE TextFile

here's my faster demo. only takes a couple of seconds including the sort by value
It's using a binary tree and insertion sort routine, which should give your C#-coding buddy a run for his money
:-) could make it a little faster if I had to, but got a job to do here as well


unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, math;

type TBigFileParser = class(TObject)
private
{$IFDEF DEBUG}  iterations: integer; {$ENDIF}
  nearest: integer;
{ the following 4 functions are used internally when parsing the string.
  they cannot be used after you have done a "CustomSort".
  So do not do a CustomSort until you have finished calling
  FindxLetterWords and FindxConsecutiveLetters}
  function BinTreeSearch(left, middle, right: integer; s: string): integer;
  function BinTreeSearchNearest(left, middle, right: integer; s: string): integer;
  function BinaryIndexOfText(s: string): integer; // can only be used before you do a customsort
  function BinaryInsertOfText(s: string): integer; // can only be used before you do a customsort
public
  Results: TStringList;
  BigText: string;
  Constructor Create;
  Destructor Destroy; override;
  procedure LoadFile(filename: string);
  procedure FindxLetterWords(wordlength: integer);
  procedure FindxConsecutiveLetters(wordlength: integer);
  function CountOf(s: string): integer; overload;
  function CountOf(s: string; canusebinarysearch: boolean): integer; overload;
end;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    Memo2: TMemo;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  function CustomSortByCount(List: TStringList; Index1, Index2: Integer): Integer;

implementation

{$R *.DFM}

function CustomSortByCount(List: TStringList; Index1, Index2: Integer): Integer;
begin
  if Integer(List.Objects[Index1]) < Integer(List.Objects[Index2]) then
    result := -1
  else if Integer(List.Objects[Index1]) > Integer(List.Objects[Index2]) then
    result := 1
  else
    result := AnsiCompareStr(List[Index1], List[Index2]);
end;

(*
function CustomSortByCount(List: TStringList; Index1, Index2: Integer): Integer;
begin
  if StrToInt(List.Values[List.Names[Index1]]) < StrToInt(List.Values[List.Names[Index2]]) then
    result := -1
  else if StrToInt(List.Values[List.Names[Index1]]) > StrToInt(List.Values[List.Names[Index2]]) then
    result := 1
  else
    result := AnsiCompareStr(List.Names[Index1], List.Names[Index2]);
end;
*)

{ TBigFileParser }

constructor TBigFileParser.Create;
begin
  inherited Create;
  Results := TStringList.Create;
end;

destructor TBigFileParser.Destroy;
begin
  Results.Clear;
  Results.Free;
  inherited Destroy;
end;

procedure TBigFileParser.LoadFile(filename: string);
  var
    FS: TFileStream;
begin
  FS := TFileStream.create(filename, fmOpenRead);
  try
    SetLength(BigText, FS.Size);
    FS.Read(PAnsiChar(BigText)^, FS.Size);
  finally
    FS.Free;
  end;
end;

procedure TBigFileParser.FindxLetterWords(wordlength: integer);
var
  i: integer;
  btlen: integer;
  partialword: string;
  c: char;
begin
//  Results.Clear; // clear our counts first - up to you if you want to do this
  partialword := '';
  BigText := lowercase(BigText);
  btlen := length(BigText);
  i := 1;
  while (i <= btlen) do
  begin
    c := BigText[i];

    if not(c in ['a'..'z']) then
    begin // assume any char not in 'a'..'z' is a delimter (space, etc)
      if length(partialword) = wordlength then
      begin // we have found a 'x' length word
        BinaryInsertOfText(partialword);
        partialword := '';
      end
      else if length(partialword) <> wordlength then
      begin
        partialword := '';
      end;
    end
    else
      partialword := partialword + c; // add this 'a'..z' char to our string
    inc(i);
  end;
  if length(partialword) = wordlength then
  begin // we have found a x length word in the last section
    BinaryInsertOfText(partialword);
  end
end;

procedure TBigFileParser.FindxConsecutiveLetters(wordlength: integer);
var
  i: integer;
  btlen: integer;
  partialword: string;
  c: char;
begin
//  Results.Clear; // clear our counts first - up to you if you want to do this
  partialword := '';
  BigText := lowercase(BigText);
  btlen := length(BigText);
  i := 1;
  while (i <= btlen) do
  begin
    c := BigText[i];

    if not(c in ['a'..'z']) then
    begin // assume any char not in 'a'..'z' is a delimter (space, etc)
      if length(partialword) = wordlength then
      begin // we have found 'x' length letters in a row, add it to our list
        BinaryInsertOfText(partialword);
        // remove the first letter of our "found text" so we can grab the next letter
        Delete(partialword, 1, 1);
      end
      else if length(partialword) <> wordlength then
      begin
        partialword := '';
      end;
    end
    else
    begin // we have not reached the end of the current text (word)
      partialword := partialword + c; // add this 'a'..z' char to our string
      if length(partialword) = wordlength then
      begin // we have found 'x' length letters in a row, add it to our list
        BinaryInsertOfText(partialword);
        // remove the first letter of our "found text" so we can grab the next letter
        Delete(partialword, 1, 1);
      end
    end;
    inc(i);
  end;
  if length(partialword) = wordlength then
  begin // we have found 'x' length letters in a row, add it to our list
    BinaryInsertOfText(partialword);
  end
end;

function TBigFileParser.BinTreeSearch(left, middle, right: integer; s: string): integer;
var
  midvalue: string;
begin
{$IFDEF DEBUG}  inc(iterations);
 Form1.memo1.lines.add(Format('%d: %d %d %d', [iterations, left, middle, right])); {$ENDIF}

  midvalue := Results[middle];
  if s < midvalue then
  begin
    if (left <> middle) and (right <> middle) then
      result := BinTreeSearch(left, left + trunc((middle - left)/2), middle, s)
    else
    begin
      if s = Results[left] then
        result := left
      else if s = results[right] then
        result := right
      else
        result := -1;
    end;
  end
  else if s > midvalue then
  begin
    if (left <> middle) and (right <> middle) then
      result := BinTreeSearch(middle, middle + trunc((right - middle)/2), right, s)
    else
    begin
      if s = Results[left] then
        result := left
      else if s = results[right] then
        result := right
      else
        result := -1;
    end;
  end
  else
    result := middle;
end;

function TBigFileParser.BinTreeSearchNearest(left, middle, right: integer; s: string): integer;
var
  midvalue: string;
begin
{$IFDEF DEBUG}  inc(iterations);
  Form1.memo1.lines.add(Format('%d: %d %d %d', [iterations, left, middle, right])); {$ENDIF}

  midvalue := Results[middle];
  if s < midvalue then
  begin
    if (left <> middle) and (right <> middle) then
      result := BinTreeSearchNearest(left, left + trunc((middle - left)/2), middle, s)
    else
    begin
      if s = Results[left] then
        result := left
      else if s = results[right] then
        result := right
      else
      begin
        result := -1;
        if s < Results[left] then Nearest := max(0, left)
        else if s > Results[right] then Nearest := right + 1
        else Nearest := right;
      end;
    end;
  end
  else if s > midvalue then
  begin
    if (left <> middle) and (right <> middle) then
      result := BinTreeSearchNearest(middle, middle + trunc((right - middle)/2), right, s)
    else
    begin
      if s = Results[left] then
        result := left
      else if s = results[right] then
        result := right
      else
      begin
        result := -1;
        if s < Results[left] then Nearest := max(0, left)
        else if s > Results[right] then Nearest := right + 1
        else Nearest := right;
      end;
    end;
  end
  else
    result := middle;
end;

function TBigFileParser.BinaryIndexOfText(s: string): integer;
begin
{$IFDEF DEBUG}  iterations := 0;{$ENDIF}
  Nearest := -1;
  result := BinTreeSearch(0, Min(trunc(results.Count div 2), pred(results.Count)), pred(results.Count), s);
end;

function TBigFileParser.BinaryInsertOfText(s: string): integer;
begin
{$IFDEF DEBUG}  iterations := 0; {$ENDIF}
  Nearest := -1;
  if Results.Count = 0 then
  begin
    Results.AddObject(s, pointer(1));
    result := 0;
  end
  else
  begin
    result := BinTreeSearchNearest(0, Min(trunc(results.Count div 2), pred(results.Count)), pred(results.Count), s);

    if result = -1 then
    begin
      if nearest = results.count then
        Results.AddObject(s, pointer(1))
      else
        Results.InsertObject(nearest, s, pointer(1));
    end
    else
    begin
      Results.Objects[result] := Pointer( Integer(Results.Objects[result]) +1 );
    end;
  end;
end;

function TBigFileParser.CountOf(s: string): integer;
begin
  result := CountOf(s, false); // assume the user has done a customsearch
end;

function TBigFileParser.CountOf(s: string; canusebinarysearch: boolean): integer;
var
  i: integer;
begin
  result := 0;
  if canusebinarysearch then i := self.BinaryIndexOfText(s)
  else i := Results.indexOf(s);
  if i <> -1 then
    result := integer(Results.Objects[i]);
end;

// *** FORM STUFF

procedure TForm1.Button1Click(Sender: TObject);
var
  i: integer;
begin
  memo1.lines.beginupdate;
  memo2.lines.beginupdate;
  with TBigFileParser.Create do
  try
    memo1.lines.Clear;
    memo2.lines.Clear;
    LoadFile('source.txt');
//    FindxLetterWords(2); // we want to find the "2" letter words
//    FindxLetterWords(4); // we want to find the "4" letter words
    FindxConsecutiveLetters(2); // we want to find strings of "2" letters in a row
    for i := 0 to pred(Results.Count) do
      memo1.lines.add(Results[i] + '=' + IntToStr(integer(Results.Objects[i])));
// now sort the results
    Results.CustomSort(CustomSortByCount);
    for i := 0 to pred(Results.Count) do
      memo2.lines.add(Results[i] + ' =' + IntToStr(integer(Results.Objects[i])));
    ShowMessage('The word "an" appears ' + IntToStr(CountOf('an')) + ' times');
  finally
    free;
    memo1.lines.endupdate;
    memo2.lines.endupdate;
  end;
end;

end.