Power-Programmierung/CD1.mdf/pascal/library/dos/sort/tpsorts/sorts.pas

Pascal/Delphi Source File | 1994-04-24 | 14.2 KB | 489 lines

{$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,P-,Q-,R-,S+,T-,V+,X+,Y+}
{$M $FFF1,0,655360}
PROGRAM Sorts;

USES Crt;
(* 10-min-translation to BP>3 by jb/'94 *)
type
    list = array[1..2000] of integer;
    longlist = array[1..3199] of integer;
const
   n: integer = 2000;                        (* number of items to sort   *)
var
    toggle   : boolean;                      (* controls display of list  *)
    master   : list;                         (* random values for sorting *)
    a        : list;                         (* working list to be sorted *)
    aux1     : longlist;                     (* auxiliary arrays used by  *)
    aux2     : longlist;                     (* count and tree sort       *)

(*  Internal arrays in count and tree sort are forced to overlay aux1 and
    aux2 using the absolute address variable ability of Turbo Pascal.  This
    saves some critical space in the program so that large lists can be
    sorted without a heap stack collision.  *)


(***** COMMON PROCEDURES USED BY SORTING ALGORITHMS *****************)

procedure swap(var i, j : integer);
    var
        t : integer;
begin
    t := i;
    i := j;
    j := t;
end;

(***** BUBBLE SORT **************************************************)

(*  The list is scanned repeatedly, and adjacent items that are out of
    order are swapped.  When a pass occurs with no swaps, the list is
    sorted.  *)

procedure bubble(lb, ub : integer);
    var
        swapped : boolean;
        cell    : integer;
begin
    repeat
        swapped := false;
        for cell := lb to ub - 1 do
        begin
            if (a[cell] > a[cell + 1]) then
            begin
                swap(a[cell], a[cell + 1]);
                swapped := true;
            end;
        end;
    until (swapped = false);
end;

(***** COUNT SORT ***************************************************)

(*  An auxiliary array is created with one cell for each item in
    the list, and these cells are set to 1.  Each pair of items
    is compared, and the auxiliary cell corresponding to the
    higher item is incremented.  The auxiliary cells then give the
    number of items smaller than any given item, which establishes
    its position in the sorted list.  *)

procedure count(lb, ub : integer);
    var
        left, right, cell : integer;
        sorted            : list absolute aux1;
        count             : list absolute aux2;
begin
    for cell := lb to ub do count[cell] := 1;
    for right := lb + 1 to ub do
    begin
        for left := lb to right - 1 do
        begin
            if (a[right] > a[left])
            then count[right] := count[right] + 1
            else count[left]  := count[left]  + 1;
        end;
    end;
    for cell := lb to ub do sorted[count[cell]] := a[cell];
    for cell := lb to ub do a[cell] := sorted[cell];
end;

(***** HEAP SORT ****************************************************)

(*  The items are rearranged into a "heap", where each item at position i
    is larger than the two items at positions 2i and 2i + 1.  The top item
    in the heap is then repeatedly removed and placed in its final position,
    with the heap being consolidated after each such removal.  *)

procedure heap(lb, ub : integer);
    var
        cell : integer;

    procedure siftup(parent, top : integer);
        label done;
        var
            child, copy : integer;
    begin
        copy := a[parent];
        repeat
            child := parent + parent;
            if (child > top) then goto done
            else
            begin
                if (child < top) and (a[child] < a[child + 1]) then
                    child := child + 1;
                if (a[child] <= copy) then goto done
                else
                begin
                    a[parent] := a[child];
                    parent := child;
                end;
            end;
        until (false);
        done:    a[parent] := copy;
    end;

begin
    for cell := (ub div 2) downto (lb + 1) do siftup(cell, ub);
    for cell := ub downto (lb + 1) do
    begin
        siftup(1, cell);
        swap(a[1], a[cell]);
    end;
end;

(***** INSERTION SORT ***********************************************)

(*  The first item is considered as the nucleus of a sorted lefthand
    sublist.  Each succeeding item to the right is compared backward
    along the left sublist and inserted at the correct position in the
    sorted portion.  *)

procedure insert(lb, ub : integer);
    var
        cell, newcell, newval : integer;
begin
    for newcell := lb + 1 to ub do
    begin
        cell := newcell;
        newval := a[cell];
        while (cell > lb) and (newval < a[cell - 1]) do
        begin
            a[cell] := a[cell - 1];
            cell := cell - 1;
        end;
        a[cell] := newval;
    end;
end;

(***** SIMPLE QUICK SORT *****************************************)


(*  A pivotal value is chosen and the list is rearranged
    so that all values to the left are less than or equal
    to the pivot and all values to the right are greater
    than or equal to the pivot.  The same procedure is then
    called recursively to deal with the left and right
    sublists.  When all sublists are of length one, the
    list is sorted.  In this version, the pivot is simply
    chosen to be the leftmost member of each sublist. *)

procedure quick1(lb, ub : integer);
    var
        left, right, pivot : integer;
begin
    if (lb < ub) then
    begin
        left := lb;
        right := ub + 1;
        pivot := a[lb];
        repeat
            repeat left  := left  + 1 until (a[left]  >= pivot);
            repeat right := right - 1 until (a[right] <= pivot);
            if (left < right) then swap(a[left], a[right]);
        until (left > right);
        swap(a[lb], a[right]);
        quick1(lb, right - 1);
        quick1(left, ub);
    end;
end;

(***** IMPROVED QUICK SORT *****************************************)

(*  This version includes two improvements:  (1) The pivot
    is chosen to be the median of the leftmost, rightmost
    and middle items in each sublist; and (2) sublists of
    less than ten items are left unsorted.  The partly sorted
    list can then be rapidly brought into complete order with
    insertion sort.  *)

procedure quick2(lb, ub : integer);
    const
        CUTOFF = 10;
    var
        left, right, pivot : integer;

    function med(lb, ub : integer) : integer;
    var
        mid : integer;
    begin
        mid := (lb + ub) div 2;
        if (a[lb] <= a[mid]) and (a[mid] <= a[ub]) then med := mid
        else if (a[lb] <= a[ub]) and (a[ub] <= a[mid]) then med := ub
        else med := lb;
    end;

begin
    if (ub - lb > CUTOFF) then
    begin
        left := lb;
        right := ub + 1;
        swap(a[lb], a[med(lb, ub)]);
        pivot := a[lb];
        repeat
            repeat left  := left  + 1 until (a[left]  >= pivot);
            repeat right := right - 1 until (a[right] <= pivot);
            if (left < right) then swap(a[left], a[right]);
        until (left > right);
        swap(a[lb], a[right]);
        quick2(lb, right - 1);
        quick2(left, ub);
    end;
end;

(***** SIMPLE SELECTION SORT ****************************************)

(*  The smallest item is found and placed in the leftmost cell.  On each
    succeeding pass, the smallest remaining unsorted item is found and
    placed at the end of the sorted lefthand portion.  *)

{procedure select(lb, ub : integer);
    var
        left, right : integer;
begin
    for left := lb to ub do
        for right := left + 1 to ub do
            if (a[left] > a[right]) then swap(a[left], a[right]);
end;}

(***** IMPROVED SELECTION SORT **************************************)

(*  In this faster version, most calls on swap are replaced by
    an explicit temporary variable, which represents the position
    holding the lowest item yet found at a given time during one
    pass.  *)

procedure select(lb, ub : integer);
    var
        left, right, low : integer;
begin
    for left := lb to ub do
    begin
        low := left;
        for right := left + 1 to ub do
            if (a[right] < a[low]) then low := right;
        swap(a[left], a[low]);
    end;
end;

(***** SIMPLE SHELL SORT ********************************************)

(*  The list is divided into a number of interlaced sublists in which
    items are separated by a gap initially equal to half the length of
    the list.  On each pass, the gap is cut in half until on the last
    pass, adjacent items are being compared.  During each pass, items
    on each of the current sublists are sorted by insertion sort.  *)

{procedure shell(lb, ub : integer);
    var
        gap, left, right  : integer;
begin
    gap := (ub - lb) div 2;
    while (gap >= lb) do
    begin
        for right := gap to ub do
        begin
            left := right - gap;
            while ((left >= lb) and (a[left] > a[left + gap])) do
            begin
                swap(a[left], a[left + gap]);
                left := left - gap;
            end;
        end;
        gap := gap div 2;
    end;
end;}

(***** IMPROVED SHELL SORT ******************************************)

(*  This version saves some time in the inner loop with a better
    version of insertion sort that uses a temporary variable to
    cut down on swaps.  *)

procedure shell(lb, ub : integer);
    var
        gap, left, right, newval : integer;
begin
    gap := (ub - lb) div 2;
    while (gap >= lb) do
    begin
        for right := gap to ub do
        begin
            left := right;
            newval := a[left];
            while (left - gap >= lb) and (newval < a[left - gap]) do
            begin
                a[left] := a[left - gap];
                left := left - gap;
            end;
            a[left] := newval;
        end;
        gap := gap div 2;
    end;
end;

(***** TREE SORT ****************************************************)

(*  In one auxiliary array, the items are arranged in a tree where
    each position i contains a copy of the smaller item at positions
    2i and 2i + 1.  A second auxiliary array contains pointers to the
    original position of each item in the first auxiliary array.  The
    first (smallest) item in the tree is repeatedly removed and
    transfered to its final position in the sorted list.  Then, it is
    replaced at its original position with a value higher than any
    item in the list, and the tree is rearranged to move the new
    smallest item to the top.  *)

procedure tree(lb, ub : integer);
    var
        cell, node : integer;
        value      : longlist absolute aux1;
        pointer    : longlist absolute aux2;

    procedure minimum(cell : integer);
    begin
        if (value[2 * cell] <= value[2 * cell + 1]) then
        begin
            value[cell] := value[2 * cell];
            pointer[cell] := pointer[2 * cell];
        end
        else
        begin
            value[cell] := value[2 * cell + 1];
            pointer[cell] := pointer[2 * cell + 1];
        end;
    end;

begin
    for cell := ub to (2 * ub - 1) do
    begin
        value[cell] := a[cell - ub + 1];
        pointer[cell] := cell;
    end;
    for cell := (ub - 1) downto lb do minimum(cell);
    for cell := lb to ub do
    begin
        a[cell] := value[lb];
        node := pointer[lb];
        value[node] := MAXINT;
        node := node div 2;
        while (node >= lb) do
        begin
            minimum(node);
            node := node div 2;
        end;
    end;
end;

(***** MAIN PROGRAM INFRASTRUCTURE **********************************)

procedure reset(n : integer);
    var
        i : integer;
begin
    for i := 1 to n + 1 do a[i] := master[i];
end;

procedure init(var n : integer);
    var
        i : integer;
begin
    writeln;
    write('Number of items to sort:  ');
    readln(n);
    for i := 1 to n do master[i] := random(2000);
    master[n + 1] := MAXINT;
    reset(n);
end;

procedure presort(n : integer);
    var
        i : integer;
begin
    quick2(1, n);
    for i := 1 to n do master[i] := a[i];
end;

procedure show(n : integer);
    var
        i : integer;
begin
    writeln;
    for i := 1 to n do
    begin
        write(a[i] : 5);
        if (i mod 10 = 0) then writeln;
    end;
end;

procedure dosort(c : char);
begin
    reset(n);
    if (toggle) then show(n);
    writeln;
    write('ready?');
    repeat until keypressed;
    write('    begin');
    case c of
        'B' : bubble(1, n);
        'C' : count(1, n);
        'H' : heap(1, n);
        'I' : insert(1, n);
        'L' : shell(1, n);
        'Q' : quick1(1, n);
        'R' : begin quick2(1, n); insert(1, n); end;
        'S' : select(1, n);
        'T' : tree(1, n);
    end;
    writeln('    end');
    if (toggle) then show(n);
end;

procedure menu;
    var
        c : char;
begin
    writeln;
    write('Options:');
    writeln;
    writeln;
    writeln(' ' : 10, 'B  Bubble sort.');
    writeln(' ' : 10, 'C  Count sort.');
    writeln(' ' : 10, 'D  toggle Display of list.');
    writeln(' ' : 10, 'H  Heap sort.');
    writeln(' ' : 10, 'I  Insertion sort.');
    writeln(' ' : 10, 'L  sheLL sort.');
    writeln(' ' : 10, 'N  Number of items to sort.');
    writeln(' ' : 10, 'P  Presort master list.');
    writeln(' ' : 10, 'Q  Quick sort.');
    writeln(' ' : 10, 'R  quick sort 2.');
    writeln(' ' : 10, 'S  Selection sort.');
    writeln(' ' : 10, 'T  Tree sort.');
    writeln(' ' : 10, 'X  eXit program.');
    writeln;
    write('Your choice?  ');
    repeat
      c := UpCase(ReadKey);
    until c <> #0;
    writeln;
    case c of
        'B', 'C', 'H', 'I', 'L', 'Q', 'R', 'S', 'T' : dosort(c);
        'D' : toggle := not toggle;
        'N' : init(n);
        'P' : presort(n);
        'X' : halt;
        else
        begin
            writeln;
            writeln('Not on menu.');
        end;
    end;
end;

(***** MAIN PROGRAM *************************************************)

begin
    toggle := true;
    repeat
      menu
    until FALSE;
end.