PROGRAM qsort(input,output);

{ Sortiert ein numerisches Feld nach dem "Quicksort"-Algorithmus }

{$A- freigabe der Rekursion durch abschalten des absoluten Codes.}

CONST max          = 100; { maximale Feldgroesse }

TYPE  standardfeld = ARRAY[0..max] OF real;

VAR   zahlen       : standardfeld;
      letzte       : integer;

{----------------------------------------------------------------------------}
PROCEDURE austauschen(VAR a,b : real);

VAR t : real;

BEGIN { austauschen }
  t := a;
  a := b;
  b := t
END;  { austauschen }

{----------------------------------------------------------------------------}
PROCEDURE feldholen(VAR umfang : integer);

{ Uebernimmt Feld von der aktiven Eingabe }

VAR index   : integer;
    eingabe : real;

BEGIN { feldholen }
  index := 0;
  WHILE NOT eof(input) DO
    BEGIN
      write('Feldelenment (',index:4,') : ');
      readln(eingabe);
      { Platz fuer einen Gueltigkeitstest }
      zahlen[index] := eingabe;
      index := succ(index)
    END;
  writeln;
  writeln('Eingegeben wurden',index:4,' Werte.');
  umfang := index-1
END;  { feldholen }

{----------------------------------------------------------------------------}
PROCEDURE felddrucken(umfang : integer);

VAR index : integer;

BEGIN { felddrucken }
  FOR index := 0 TO umfang DO
    BEGIN
      IF index/4 = trunc(index/4) THEN writeln;
      write(zahlen[index]:8:2)
    END
END; { felddrucken }

{----------------------------------------------------------------------------}
PROCEDURE bsort(anfang,ende : integer; VAR feld : standardfeld);

{ Sortiert ein Feld von "anfang" bis "ende" nach dem Bubble-Sort-Prinzip. }

VAR index        : integer;
    ausgetauscht : boolean;

BEGIN { bsort }
  REPEAT
    ausgetauscht := false;
    FOR index := anfang TO ende-1 DO
      BEGIN
        IF feld[index] > feld[index+1] THEN
          BEGIN
            austauschen(feld[index],feld[index+1]);
            ausgetauscht := true
          END
      END;
  UNTIL ausgetauscht = false
END;  { bsort }

{----------------------------------------------------------------------------}
PROCEDURE ausmitten(anfang,ende : integer ; VAR feld : standardfeld);

{ Sucht einen brauchbaren mittleren Wert im "feld" und setzt ihn an den }
{ Anfang des zu sortirenden Abschnitts. }

VAR inmitten : integer;
    sortiert : standardfeld; { "sortiert" benoetigt nur 3 Elemente von }
                             { "standardfeld"! (Platzverschwendung) }
BEGIN { ausmitten }
  inmitten := (anfang + ende) div 2;
  sortiert[1] := feld[anfang];
  sortiert[2] := feld[ende];
  sortiert[3] := feld[inmitten];
  bsort(1,3,sortiert);
  IF sortiert[2] = feld[inmitten] THEN
    austauschen(feld[anfang],feld[inmitten])
  ELSE IF sortiert[2] = feld[ende] THEN
    austauschen(feld[anfang],feld[ende])
END; { ausmitten }

{----------------------------------------------------------------------------}
PROCEDURE sortieren(anfang,ende : integer);

{ Sortiert einen Abschnitt des Hauptfeldes nach dem Quick-Sort-Verfahren }
{ und teilt ihn dann in zwei Abschnitte auf, die zu sortieren sind. }

CONST grenze = 6;

VAR richtung : boolean;
    a,e,m    : integer;

BEGIN
  IF ende-anfang < grenze THEN { kleine Felder mit "bsort" sortieren }
    bsort(anfang,ende,zahlen)
    { Endekriterium im rekursiven Aufruf der Procedure "sortieren" }
  ELSE
    BEGIN
      ausmitten(anfang,ende,zahlen);
      richtung := true;
      { vom "ende" her untersuchen }
      a := anfang; { untere Vergleichsgrenze }
      e := ende;   { obere  Vergleichsgrenze }
      m := anfang; { Ort des Vergleichwertes }
      WHILE e > a DO
        BEGIN
          IF richtung = true THEN
            { Vom Abschnittsende her untersuchen und }
            { austauschen falls kleiner als das Mittel. }
            BEGIN
              WHILE (zahlen[e] >= zahlen[m]) AND (e > m) DO
                e := e-1;
              IF e > m THEN
                BEGIN
                  austauschen(zahlen[e],zahlen[m]);
                  m := e
                END;
              richtung := false
            END
          ELSE
            { Vom Abschnittsanfang her untersuchen und }
            { austauschen falls groesser als das Mittel. }
            BEGIN
              WHILE (zahlen[a] <= zahlen[m]) AND (a < m) DO
                a := a+1;
              IF a < m THEN
                BEGIN
                  austauschen(zahlen[a],zahlen[m]);
                  m := a
                END;
              richtung := true
            END
        END;

      { Die neuen Abschnitte werden rekursiv von links nach rechts }
      { weiter sortiert. }

      sortieren(anfang,m-1); { untere Abschnittshealfte sortieren }
      sortieren(m+1,ende);   { obere  Abschnittshaelfte sortieren }
    END
END; { sortieren }

{============================================================================}
BEGIN { qsort }
  feldholen(letzte);
  sortieren(0,letzte);
  felddrucken(letzte)
END. { qsort }