Unit SortUnit;

Interface

Type
  TType = Integer;

  TSortings =
    (srBubble, srInsert, srMerge, srHoarFirst,
     srHoarSecond, srHeap);
  TOrder =
    (orAscending, orDescending);

Procedure SuperSort(Var arr: Array Of TType; n: Integer;
          Style: TSortings; Order: TOrder);

Implementation

Type
  TOrderType =
    Function(a, b: Real): Boolean;

Function SortAscend(a, b: Real): Boolean; Far;
  Begin SortAscend := (a > b) End;
Function SortDescend(a, b: Real): Boolean; Far;
  Begin SortDescend := (a < b) End;


Function Index(x: Word): Word;
  Begin Index := Pred(x) End;
Procedure Swap(Var a, b: TType);
  Var T: TType;
  Begin
    T := a; a := b; b := T
  End;


Procedure Bubble(Var ar: Array Of TType; n: integer;
          Order: TOrderType); Far;
  Var i, j: Integer;
  Begin
    For i := 1 To n Do
      For j := n DownTo i+1 Do
        If Order(ar[Index(Pred(j))], ar[Index(j)]) Then
          Swap(ar[Index(Pred(j))], ar[Index(j)])
  End;


Procedure Insert(Var ar: Array Of TType; n: Integer;
          Order: TOrderType); Far;
  Var i, j: Integer; T: TType;
  Begin
    For i := 1 To n do
      Begin
        T := ar[Index(i)];
        j := Pred(i);
        While Order(ar[Index(j)], T) and (j >= 1) Do
          Begin
            ar[Index(Succ(j))] := ar[Index(j)]; Dec(j);
          End;
        ar[Index(Succ(j))] := T;
      End;
  End;


Procedure merge(Var ar: Array Of TType; n: Integer;
          Order: TOrderType); Far;

  Procedure Slit( k, q: Integer );
    Type
      TArr =
        Array[1 .. maxInt Div SizeOf(TType)] Of TType;
    Var
      m: Integer;
      i, j, T: Integer;
      d: ^TArr;
    Begin
      GetMem(d, n * SizeOf(TType));

      m := k + (q-k) div 2;
      i := k; j := Succ(m); T := 1;
      While (i <= m) and (j <= q) Do
        Begin
          If Order(ar[Index(j)], ar[Index(i)]) Then
            Begin
              d^[T] := ar[Index(i)]; Inc(i)
            End
          Else
            Begin
              d^[T] := ar[Index(j)]; Inc(j)
            End;
          Inc(T)
        End;

      While i <= m Do
        Begin
          d^[T] := ar[Index(i)]; Inc(i); Inc(T)
        End;

      While j <= q Do
        Begin
          d^[T] := ar[Index(j)]; Inc(j); Inc(T)
        End;

      For i := 1 to Pred(T) Do
        ar[Index(Pred(k+i))] := d^[i];

      FreeMem(d, n * SizeOf(TType));
    End;

  Procedure Sort(i, j: Integer);
    Begin
      If i >= j Then Exit;

      If j-i = 1 Then
        Begin
          If Order(ar[Index(i)], ar[Index(j)]) Then
            Swap(ar[Index(i)], ar[Index(j)])
        End
      Else
        Begin
          Sort(i, i + (j-i) div 2);
          Sort(i + (j-i) div 2 + 1, j);
          Slit(i, j)
        End;
    End;

  Begin
    Sort(1, n);
  End;


Procedure HoarFirst(Var ar: Array Of TType; n: integer;
          Order: TOrderType); Far; { Variant 1 }

  Procedure sort(m, l: Integer);
    Var i, j: Integer; x, w: TType;
    Begin

      i := m; j := l;
      x := ar[Index((m+l) div 2)];
      Repeat

        While Order(x, ar[Index(i)]) Do Inc(i);
        While Order(ar[Index(j)], x) Do Dec(j);
        If i <= j Then
          Begin
            Swap(ar[Index(i)], ar[Index(j)]);
            Inc(i); Dec(j)
          End

      Until i > j;
      If m < j Then Sort(m, j);
      If i < l Then Sort(i, l)

    End;

  Begin
    sort(1, n)
  End;

Procedure HoarSecond(Var ar: Array Of TType; n: Integer;
          Order: TOrderType); Far; { Variant 2 }

  Procedure Sort(m, l: Integer);
    Var i, j: Integer; x, w: TType;
    Begin
      If m >= l Then Exit;
      i := m; j := l;
      x := ar[Index((m+l) div 2)];

      While i < j Do
        If Order(x, ar[Index(i)]) Then Inc(i)
        Else
          If Order(ar[Index(j)], x) Then Dec(j)
          Else
            Swap(ar[Index(i)], ar[Index(j)]);
      Sort(m, Pred(j));
      Sort(Succ(i),l);
    End;

  Begin
    Sort(1, n)
  End;


Procedure HeapSort(Var ar: Array Of TType; n: Integer;
          Order: TOrderType); Far;
  Var
    i, Left, Right: integer;
    x: TType;

  Procedure sift;
    Var
      i, j: Integer;
    Begin
      i := Left; j := 2*i; x := ar[Index(i)];
      While j <= Right Do
        Begin
          If j < Right Then
            If Order(ar[Index(Succ(j))], ar[Index(j)]) Then Inc(j);

          If Order(x, ar[Index(j)]) Then Break;
          ar[Index(i)] := ar[Index(j)];
          i := j; j := 2 * i
        End;

      ar[Index(i)] := x
    End;

  Begin
    Left := Succ(n div 2); Right := n;
    While Left > 1 Do
      Begin
        Dec(Left); sift
      End;

    While Right > 1 Do
      Begin
        Swap(ar[Index(Left)], ar[Index(Right)]);
        Dec(Right); sift
      End
  End;



Type
  TSortProc =
    Procedure(Var ar: Array Of TType; n: Integer;
              Order: TOrderType);

Procedure SuperSort(Var arr: Array Of TType; n: Integer;
          Style: TSortings; Order: TOrder);
  Const
    sortProc: Array[TSortings] Of TSortProc =
      (Bubble, Insert, Merge, HoarFirst, HoarSecond, HeapSort);
    sortOrder: Array[TOrder] Of TOrderType =
      (SortAscend, SortDescend);

  Begin
    sortProc[Style](arr, n, sortOrder[Order]);
  End;

End.