{*************************************************************************
* 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.
*
*
* 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.