Quick Sort Example with Source Code

Hello, I found an answer to my question about Quick Sort. I've made a
small example application. I hope it is useful to some. Sorry about
the length.

{*************************************************************************
* This is a small example application which demonstrates the use of
* the QSort procedure to sort the contents of a Listbox.
*
* Developed Oct 95 by Barry Schlereth
*
*                  ??? WHY ???
*
* The sorted parameter of a Listbox is nice, but what if you want to
* sort the strings by their numerical representation not
alphabetically?
* Or, maybe you have a table and you would like to sort the rows of
the
* table according to the floating point numbers displayed in one
column.
*
* That is what this example shows. I hope you find it useful.
*
* This example can be freely distributed. Be sure to follow the
* copyrights shown below.
*
*                  ??? HOW ???
*
* 1) Save this entire text file as Sort1.txt
* 2) Start Delphi. Do File|CloseProject
* 3) File|OpenFile Sort1.txt (You will get DFM not found error)
* 4) Go to bottom of this file. Edit|Copy the stuff for Sorttst.dpr.
* 5) Do File|New Unit. Select all the text in the new unit then do
*    Edit|Paste to replace it all. File|Save File As Sorttst.dpr.
* 6) From bottom of this file. Edit|Copy the stuff for Sort1.dfm.
* 7) Do File|New Unit. Select all the stuff in the new unit then do
*    Edit|Paste to replace it all. File|Save File As Sort1.dfm.
* 8) Now delete everything past the "End." from the file Sort1.txt and
*    File|Save File As Sort1.pas.
* 9) File|Close File for all files. File|Open Project Sorttst.dpr.
* 10) You should be all set to run.
*
* If you feel very appreciative, a small donation - 1 dollar or a
couple
* cereal coupons (Special K, Corn Flakes, Cheerios) - may be sent to:
*
*     Barry
*     Box 176
*     Syracuse, NY  13215
*
*************************************************************************}

unit Sort1;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    DataBox1: TListBox;
    DataBox2: TListBox;
    BtnSort: TButton;
    BtnInit: TButton;
    Label1: TLabel;
    Label2: TLabel;
    BtnQSort: TButton;
    EdPts: TEdit;
    Label3: TLabel;
    Label4: TLabel;
    procedure BtnInitClick(Sender: TObject);
    procedure BtnSortClick(Sender: TObject);
    procedure BtnQSortClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

  procedure QSort(var a: array of Integer; const lo0, hi0: Integer);
  function Compare (const i, j: Integer) : Integer;

implementation

{$R *.DFM}

procedure TForm1.BtnInitClick(Sender: TObject);
var
  i : Integer;
  f : Single;
begin
  Label4.Caption := 'Initializing';
  Application.ProcessMessages;

  DataBox1.Items.Clear;
  DataBox2.Items.Clear;
  DataBox1.Sorted := False;
  DataBox2.Sorted := False;
  Application.ProcessMessages;

  if (StrToInt(EdPts.Text) > 5000) then begin
    EdPts.Text := '5000';
    Application.ProcessMessages;
  end;

  for i:=StrToInt(EdPts.Text) downto 1 do begin
    f := i;
    DataBox1.Items.Add(FloatToStrF(f, ffFixed, 10, 1));
  end;

  BtnSort.Enabled := True;
  BtnQSort.Enabled := True;

  Label4.Caption := '';
end;

procedure TForm1.BtnSortClick(Sender: TObject);
begin
  Label4.Caption := 'Copying';
  Application.ProcessMessages;
  DataBox2.Items.Clear;
  DataBox2.Sorted := False;
  DataBox2.Items.AddStrings(DataBox1.Items);

  Label4.Caption := 'Sorting';
  Application.ProcessMessages;
  DataBox2.Sorted := True;

  Label4.Caption := '';
end;

procedure TForm1.BtnQSortClick(Sender: TObject);
type
  IdxArray = array [0..4999] of Integer;
Var
  idx : ^IdxArray;
  i, n : Integer;
begin
  Label4.Caption := 'Initialize';
  Application.ProcessMessages;

  DataBox2.Items.Clear;
  DataBox2.Sorted := False;
  Application.ProcessMessages;

  New(idx);

  n := DataBox1.Items.Count;

  for i:=0 to n-1 do Idx^[i] := i;

  Label4.Caption := 'Quick Sort';
  Application.ProcessMessages;

  QSort(Idx^, 0, n-1);

  Label4.Caption := 'Display';
  Application.ProcessMessages;

  for i := 0 to n-1 do
    DataBox2.Items.Add(DataBox1.Items[Idx^[i]]);
  Application.ProcessMessages;

  Dispose(Idx);

  Label4.Caption := '';
end;

{********************************************************************
* QSort - Quick Sort
* Adapted for Delphi Pascal by Barry Schlereth   Oct 95
*
* Permission to use, copy, modify, and distribute this software
* and its documentation for NON-COMMERCIAL purposes and without
* fee is hereby granted provided that this copyright notice and the
* original copyright appears in all copies. (Also see below)
*
* THIS SOURCE CODE IS SUPPLIED "AS IS" AND IS NOT WARRANTIED IN ANY
* WAY, EXPRESS OR IMPLIED.
*
* Original "C" implementation by James Gosling (see below)
*
* The QSort procedure takes three parameters:
*   a   - an integer array of indices.
*   lo0 - the lower index of a to sort.
*   hi0 - the top index of a to sort (Count of a -1)
*
* Qsort requires a companion function, Compare(i, j), which tells
* it how to sort the indices. Compare returns -1, 0, +1, (<, =, >)
* depending on the relationship of a[i] to a[j]. In this example
* Compare(i, j) compares the StrToFloat of Item[i] to Item[j] in
* the ListBox (DataBox1).
*
* QSort is recursive - watch your stack when sorting large arrays.
*
*-----------------------------------------------------------------
* Quick Sort Algorithm
* original implementation by James Gosling v1.6 95/01/31
*
* Copyright (c) 1994 Sun Microsystems, Inc. All Rights Reserved.
*
* Permission to use, copy, modify, and distribute this software
* and its documentation for NON-COMMERCIAL purposes and without
* fee is hereby granted provided that this copyright notice
* appears in all copies. Please refer to the file "copyright.html"
* for further important copyright and licensing information.
*
* SUN MAKES NO REPRESENTATIONS OR WARRANTIES ABOUT THE SUITABILITY OF
* THE SOFTWARE, EITHER EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED
* TO THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A
* PARTICULAR PURPOSE, OR NON-INFRINGEMENT. SUN SHALL NOT BE LIABLE FOR
* ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
* DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES.
*---------------------------------------------------------------------}

procedure QSort(var a: array of Integer; const lo0, hi0: Integer);
var
  lo, hi, mid, t : Integer;
begin
  lo := lo0;
  hi := hi0;
  Application.ProcessMessages;

  if (lo < hi) then begin
    mid := (lo + hi) div 2;

    while (lo < hi) do begin
      while ((lo<hi) and (Compare(a[lo], a[mid]) < 0)) do inc(lo);

      while ((lo<hi) and (Compare(a[hi], a[mid]) > 0)) do dec(hi);

      if (lo < hi) then begin
        t := a[lo];
        a[lo] := a[hi];
        a[hi] := t;
      end;
    end;

    if (hi < lo) then begin
      t := hi;
      hi := lo;
      lo := t;
    end;

    QSort(a, lo0, lo);
    if (lo = lo0) then t := lo+1 else t := lo;
    QSort(a, t, hi0);
  end;
end;

{ This is the companion function Compare. It provides the relationship
  comparison for QSort. The indicies (i, j) can index into any type of
  Array, StringList, etc. In real-life you would speed things alot by
  by building and sorting a dummy floating point array derived from
the
  values in DataBox1.Items instead of converting with each comparison
  as is shown in this example! }

function Compare (const i, j: Integer) : Integer;
var
  f, g : Single;
begin
  f := StrToFloat(Form1.DataBox1.Items[i]);
  g := StrToFloat(Form1.DataBox1.Items[j]);

  if (f < g) then Compare := -1
  else if (f > g) then Compare := 1
  else Compare := 0;
end;

end.

***************** SORTTST.DPR starts here *****************
program Sorttst;

uses
  Forms,
  Sort1 in 'SORT1.PAS' {Form1};

{$R *.RES}

begin
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.
********************** End *********************************

***************** SORT1.DFM starts here *****************
object Form1: TForm1
  Left = 265
  Top = 204
  Width = 435
  Height = 300
  Caption = 'Sort Test'
  Font.Color = clBlack
  Font.Height = -17
  Font.Name = 'Arial'
  Font.Style = [fsBold]
  PixelsPerInch = 120
  TextHeight = 19
  object Label1: TLabel
    Left = 24
    Top = 8
    Width = 73
    Height = 19
    Caption = 'Unsorted'
  end
  object Label2: TLabel
    Left = 168
    Top = 8
    Width = 53
    Height = 19
    Caption = 'Sorted'
  end
  object Label3: TLabel
    Left = 304
    Top = 32
    Width = 43
    Height = 19
    Caption = 'N Pts'
  end
  object Label4: TLabel
    Left = 304
    Top = 216
    Width = 113
    Height = 20
    Alignment = taCenter
    AutoSize = False
    Font.Color = clRed
    Font.Height = -17
    Font.Name = 'System'
    Font.Style = [fsBold]
    ParentFont = False
  end
  object DataBox1: TListBox
    Left = 24
    Top = 32
    Width = 121
    Height = 225
    ItemHeight = 19
    TabOrder = 0
  end
  object DataBox2: TListBox
    Left = 168
    Top = 32
    Width = 121
    Height = 225
    ItemHeight = 19
    TabOrder = 1
  end
  object BtnSort: TButton
    Left = 304
    Top = 112
    Width = 113
    Height = 33
    Caption = 'Sorted Prop'
    Enabled = False
    TabOrder = 2
    OnClick = BtnSortClick
  end
  object BtnInit: TButton
    Left = 304
    Top = 64
    Width = 113
    Height = 33
    Caption = 'Init Data'
    TabOrder = 3
    OnClick = BtnInitClick
  end
  object BtnQSort: TButton
    Left = 304
    Top = 160
    Width = 113
    Height = 33
    Caption = 'Quick Sort'
    Enabled = False
    TabOrder = 4
    OnClick = BtnQSortClick
  end
  object EdPts: TEdit
    Left = 360
    Top = 24
    Width = 57
    Height = 27
    TabOrder = 5
    Text = '350'
  end
end
*************************** End *********************************