Turbo Toolbox/Turbo_Toolbox.iso/extra18/grdlagen/sort/hrs.pas

Pascal/Delphi Source File | 1992-01-28 | 14.6 KB | 527 lines

(* ------------------------------------------------- *)
(*                      HRS.PAS                      *)
(*            (c) 1992 H.Rüter & DMV-Verlag          *)
(* ------------------------------------------------- *)
(*       Sortierroutinen für Listen und Arrays       *)
(* ------------------------------------------------- *)
(*$R-,S-,I-,V-,B-,O-,A+,D+ *)
                    (* Größtmögliche Geschwindigkeit *)
UNIT HRS;

INTERFACE

TYPE
  SetOfChar = SET OF CHAR;

  CompTyp   = (Kleiner, Gleich, Groesser);
                    (* Für die Element-Vergleiche    *)

  ListTyp   = (Einfach, Doppelt);
                (* Einfache oder doppelte Verkettung *)

  SortFunc  =
(*$IFDEF VER40 *)
              Pointer;
(*$ELSE *)
              Function(El1, El2 : Pointer;
                       CompPara : WORD) : CompTyp;
(*$ENDIF *)

CONST
  MaxIndex  = 16000;
             (* Maximalzahl zu sortierender Elemente *)
             (* Bei Compiler-Meldung "Structure too  *)
             (* large" verkleinern                   *)

  SortOkay       = 0;            (* Fehlerkonstanten *)
  MemError       = 1;
  ToMuchElements = 2;

(* --- Hilfsroutinen  für die Testprogramme          *)

FUNCTION  GetChar(Menge : SetOfChar) : CHAR;
PROCEDURE DummyRead;
FUNCTION  Min(A, B : WORD) : WORD;

(* --- Vergleichsroutinen                            *)

FUNCTION  Compare(VAR X, Y; Size : WORD) : BOOLEAN;

FUNCTION  Equal(VAR X, Y; Size : WORD) : CompTyp;

(* ------------------------------------------------- *)

FUNCTION SortError : BYTE;
(*  Gibt letzten FehlerStatuswert zurück             *)

(* ------------------------------------------------- *)

(* ------------------------------------------------- *)
(*    Sortierroutinen für Listen                     *)
(*                                                   *)
(*    Liste    --> Zeiger auf den Listenanfang       *)
(*    LTyp     --> doppelt oder einfach verkettete   *)
(*                 Liste                             *)
(*    CompF    --> Vergleichsfunktion vom Typ        *)
(*                 »SortFunc«                        *)
(*    CompPara --> Parameter zur Steuerung der       *)
(*                 Vergleichsfunktion                *)
(*                                                   *)
(* Falls ein Fehler auftritt, wird die Liste unver-  *)
(* ändert gelassen.                                  *)
(* Fehlerabfrage durch Funktion »SortError«.         *)
(* ------------------------------------------------- *)

PROCEDURE AuswahlSort(VAR Liste    : Pointer;
                          LTyp     : ListTyp;
                          CompF    : SortFunc;
                          CompPara : WORD);

PROCEDURE AustauschSort(VAR Liste    : Pointer;
                            LTyp     : ListTyp;
                            CompF    : SortFunc;
                            CompPara : WORD);

PROCEDURE EinfuegeSort(VAR Liste    : Pointer;
                           LTyp     : ListTyp;
                           CompF    : SortFunc;
                           CompPara : WORD);

PROCEDURE QuickSort(VAR Liste    : Pointer;
                        LTyp     : ListTyp;
                        CompF    : SortFunc;
                        CompPara : WORD);

(* ------------------------------------------------- *)
(*    Sortierroutine für Array                       *)
(*                                                   *)
(*    APtr     --> Zeiger auf das Array              *)
(*    ASize    --> Größe des Arrays (von 1 .. ASize) *)
(*    ElSize   --> Größe eines Arrayelements         *)
(*    CompF    --> Vergleichsfunktion vom Typ        *)
(*                 »SortFunc                         *)
(*    CompPara --> Parameter zur Steuerung der       *)
(*                 Vergleichsfunktion                *)
(*                                                   *)
(* Falls ein Fehler auftritt, wird die Liste unver-  *)
(* ändert gelassen.                                  *)
(* Fehlerabfrage durch Funktion »SortError«.         *)
(* ------------------------------------------------- *)

PROCEDURE ArraySort(APtr   : Pointer; ASize : WORD;
                    ElSize : WORD;    CompF : SortFunc;
                    CompPara : WORD);

(* ------------------------------------------------- *)

IMPLEMENTATION

USES Crt;

TYPE
  Index    = 0..MaxIndex;

  SPtr     = ^SortPtr;
            (* Hilfstypen zur Bearbeitung der Listen *)

  SortPtr  = RECORD (* Prototyp eines Listenelements *)
               Next, Last : SPtr;
             END;

  SortArray = ARRAY [1..MaxIndex] OF Pointer;
                         (* Das zu sortierende Array *)
  ArrayPtr  = ^SortArray;
                         (* .. und der Zeiger darauf *)

CONST
  SError : BYTE = 0;     (* Fehlervariable           *)

VAR
  CompFunc : SortFunc;

(* ------------------------------------------------- *)
(* Die nächsten beiden Routinen sind für die Version *)
(* 4.0 von Turbo-Pascal implementiert worden, um     *)
(* auch dort den Aufruf einer Routine mittels Zeiger *)
(* zu ermöglichen.Beispiel : Routine Quicksort       *)
(* ------------------------------------------------- *)

(*$IFDEF Ver40 *)
  FUNCTION CallCompFunc(El1, El2 : Pointer;
                        CompPara : WORD) : CompTyp;
  INLINE($FF/$1E/CompFunc );   {Call Far }

  PROCEDURE InitSortFunc(P : SortFunc);
  BEGIN
    CompFunc := P;
  END;
(*$ENDIF *)

(* --- Externe Assembler-Routinen                    *)

(*$L Comp *)
  FUNCTION  Compare(Var X, Y; Size : WORD) : BOOLEAN;
  EXTERNAL;

  FUNCTION  Equal(VAR X, Y; Size : WORD) : CompTyp;
  EXTERNAL;

(* ------------------------------------------------- *)

  FUNCTION GetChar(Menge : SetOfChar) : CHAR;
  VAR
    c : CHAR;
  BEGIN
    REPEAT
      c := ReadKey;
    UNTIL c IN Menge;
    GetChar := c;
  END;

  PROCEDURE DummyRead;
  VAR
    c : CHAR;
  BEGIN
    REPEAT
      c := ReadKey;
    UNTIL C <> #0;
  END;

  FUNCTION Min(A, B : WORD) : WORD;
  BEGIN
    IF A < B THEN Min := A
             ELSE Min := B;
  END;

(* --- Fehlerabfrageroutine                          *)

  FUNCTION SortError : BYTE;
  BEGIN
    SortError := SError;
    SError    := SortOkay;
  END;

  FUNCTION ListSize(Liste : Pointer) : Longint;
  (* Ermittelt die Anzahl der Listenelemente         *)
  VAR
    L : Index;
    P : SPtr;
  BEGIN
    L := 0;
    P := SPtr(Liste);

    WHILE P <> NIL DO BEGIN
      Inc(L);
      P := P^.Next
    END;
    ListSize := L;
  END;

  PROCEDURE ArrayToListe(APtr      : ArrayPtr;
                         ArraySize : LongInt;
                         VAR Liste : Pointer;
                             LTyp  : ListTyp);
  VAR
    L  : Index;
    P1 : SPtr;
  BEGIN
    FOR L := 1 TO ArraySize DO BEGIN
      P1 := APtr^[L];

      IF L < ArraySize THEN
        P1^.Next := APtr^[Succ(L)]     (* Verkettung *)
      ELSE
        P1^.Next := NIL;

      IF LTyp = Doppelt THEN BEGIN
        IF L = 1 THEN
          P1^.Last := NIL        (* Doppelverkettung *)
        ELSE
          P1^.Last := APtr^[Pred(L)];
      END;
    END;
    Liste := APtr^[1];
  END;

  PROCEDURE ListeToArray(Liste : Pointer;
                         APtr  : ArrayPtr;
                         ASize : Longint);
  VAR
    L : Index;
    P : SPtr;
  BEGIN
    L := 0;
    P := SPtr(Liste);

    WHILE (P <> NIL) AND (L <= Asize) DO BEGIN
      Inc(L);
      APtr^[L] := P;
      P        := P^.Next
    END;
  END;

  FUNCTION GetArrayMem(ASize : WORD;
                       VAR P : Pointer) : BYTE;
  BEGIN
    GetArrayMem := Sortokay;
    IF ASize > MaxIndex THEN BEGIN
      GetArrayMem := ToMuchElements;
      Exit;
    END;
    IF MaxAvail >= ASize * SizeOf(Pointer) THEN
      GetMem(P, ASize * SizeOf(Pointer))
    ELSE
      GetArrayMem := MemError;
  END;

  PROCEDURE QuickSort(VAR Liste    : Pointer;
                          LTyp     : ListTyp;
                          CompF    : SortFunc;
                          CompPara : WORD);
  VAR
    ArraySize : Index;
    P, Tausch : Pointer;
    APtr      : ArrayPtr;

    PROCEDURE QSort(Links, Rechts : WORD);
                   (* Die eigentliche Sortierroutine *)
    VAR
      I, J, M : Index;
    BEGIN
      I := Links;
      J := Rechts;
      M := Rechts;
      REPEAT
(*$IFDEF VER40 *)
        WHILE (CallCompFunc(APtr^[I],
                    APtr^[M], CompPara) = Kleiner) AND
              (I < ArraySize) DO Inc(I);

        WHILE (CallCompFunc(APtr^[J],
                    APtr^[M],CompPara) = Groesser) AND
              (J > 1) DO Dec(J);
(*$ELSE *)
        WHILE (CompF(APtr^[I], APtr^[M],
                              CompPara) = Kleiner) AND
              (I < ArraySize) DO Inc(I);

        WHILE (CompF(APtr^[J], APtr^[M],
                             CompPara) = Groesser) AND
              (J > 1) DO Dec(J);
(*$ENDIF *)

        IF I <= J THEN BEGIN
          Tausch   := APtr^[I];
          APtr^[I] := APtr^[J];
          APtr^[J] := Tausch;
          Inc(I);
          Dec(J);
        END;
      UNTIL I > J;

      IF Links  < J THEN QSort(Links, J);
      IF Rechts > I THEN QSort(I, Rechts);
    END;

  BEGIN
    ArraySize := ListSize(Liste);

    SError    := GetArrayMem(ArraySize,P);
    IF SError <> SortOkay THEN Exit;

    APtr := P;
    ListeToArray(Liste, APtr, ArraySize);

(*$IFDEF VER40 *)
    InitSortFunc(Compf);
(*$ENDIF *)
    QSort(1, ArraySize);

    ArrayToListe(APtr, ArraySize, Liste, LTyp);
    FreeMem(P, ArraySize * SizeOf(Pointer));
  END;

  PROCEDURE AustauschSort(VAR Liste    : Pointer;
                              LTyp     : ListTyp;
                              CompF    : SortFunc;
                              CompPara : WORD);
  VAR
    ArraySize : Index;
    P         : Pointer;
    APtr      : ArrayPtr;
    I,J       : Index;
    Hilf      : Pointer;
  BEGIN
    ArraySize := ListSize(Liste);

    SError    := GetArrayMem(ArraySize,P);
    IF SError <> SortOkay THEN Exit;

    APtr := P;

    ListeToArray(Liste, APtr, ArraySize);
                                       (* Umwandlung *)

    FOR I := 2 TO ArraySize DO         (* Sortierung *)
      FOR J := ArraySize DOWNTO I DO BEGIN
        IF (CompF(APtr^[Pred(J)], APtr^[J],
                       CompPara) = Groesser) THEN BEGIN
          Hilf           := APtr^[Pred(J)];
          APtr^[Pred(J)] := APtr^[J];
          APtr^[J]       := Hilf;
        END;
      END;

    ArrayToListe(APtr, ArraySize, Liste, LTyp);
                                    (* Konvertierung *)
    FreeMem(P, ArraySize * SizeOf(Pointer));
  END;

  PROCEDURE EinfuegeSort(VAR Liste    : Pointer;
                             LTyp     : ListTyp;
                             CompF    : SortFunc;
                             CompPara : WORD);
  VAR
    ArraySize : Index;
    P         : Pointer;
    APtr      : ArrayPtr;
    I,J,K     : Index;
    Hilf      : Pointer;
  BEGIN
    ArraySize := ListSize(Liste);

    SError    := GetArrayMem(ArraySize,P);
    IF SError <> SortOkay THEN Exit;

    APtr := P;

    ListeToArray(Liste, APtr, ArraySize);

    FOR I := 2 TO ArraySize DO BEGIN
      Hilf := APtr^[I];
      J := 1;
      WHILE (CompF(Hilf, APtr^[J],
                              CompPara) = Groesser) AND
            (J < I) DO Inc(J);
      IF J < I THEN
        FOR K := I DOWNTO Succ(J) DO
          APtr^[K] := APtr^[Pred(K)];
      APtr^[J] := Hilf;
    END;

    ArrayToListe(APtr, ArraySize, Liste, LTyp);
    FreeMem(P, ArraySize * SizeOf(Pointer));
  END;

  PROCEDURE AuswahlSort(VAR Liste    : Pointer;
                            LTyp     : ListTyp;
                            CompF    : SortFunc;
                            CompPara : WORD);
  VAR
    ArraySize : Index;
    P         : Pointer;
    APtr      : ArrayPtr;
    I,J,M     : Index;
    Hilf      : Pointer;
  BEGIN
    ArraySize := ListSize(Liste);

    SError    := GetArrayMem(ArraySize,P);
    IF SError <> SortOkay THEN Exit;

    APtr := P;
    ListeToArray(Liste, APtr, ArraySize);

    FOR I := 1 TO Pred(ArraySize) DO BEGIN
      M   := I;
      FOR J := Succ(I) TO ArraySize DO

        IF (CompF(APtr^[M], APtr^[J],
                     CompPara) = Groesser) THEN M := J;
      Hilf     := APtr^[I];
      APtr^[I] := APtr^[M];
      APtr^[M] := Hilf;
    END;

    ArrayToListe(APtr, ArraySize, Liste, LTyp);
    FreeMem(P, ArraySize * SizeOf(Pointer));
  END;

  PROCEDURE ArraySort(APtr     : Pointer;
                      ASize    : WORD;
                      ElSize   : WORD;
                      CompF    : SortFunc;
                      CompPara : WORD);
  (* Routine für das Sortieren beliebiger Arrays     *)
  (* Algorithmus : Quicksort                         *)
  VAR
    Tausch     : Pointer;
    ASeg, AOfs : WORD;

    PROCEDURE QSort(Links, Rechts : WORD);
    VAR
      I, J, M : Index;
    BEGIN
      I := Links;
      J := Rechts;
      M := Rechts;
      REPEAT
(*$IFDEF VER40 *)
        WHILE (CallCompFunc(Ptr(ASeg,
               AOfs+Pred(I)*ElSize),
          Ptr(Aseg, AOfs+Pred(M)*ElSize),
                               CompPara) = Kleiner) AND
             (I < ASize) DO Inc(I);

        WHILE (CallCompFunc(Ptr(ASeg,
               AOfs+Pred(J)*ElSize),
               Ptr(Aseg,AOfs+Pred(M)*ElSize),
                   CompPara) = Groesser) AND
              (J > 1) DO Dec(J);
(*$ELSE *)
        WHILE (CompF(Ptr(ASeg, AOfs+Pred(I)*ElSize),
              Ptr(Aseg, AOfs+Pred(M)*ElSize),
              CompPara) = Kleiner) AND
              (I < ASize) DO Inc(I);

        WHILE (CompF(Ptr(ASeg, AOfs+Pred(J)*ElSize),
              Ptr(Aseg, AOfs+Pred(M)*ElSize),
              CompPara) = Groesser) AND
              (J > 1) DO Dec(J);
(*$ENDIF *)

      IF I <= J THEN BEGIN
        Move(Mem[ASeg:AOfs+Pred(I) * ElSize],
             Tausch^,ElSize);
        Move(Mem[Aseg:AOfs+Pred(J) * ElSize],
             Mem[Aseg:AOfs+Pred(I) * ElSize], ElSize);
        Move(Tausch^,
             Mem[ASeg:AOfs+Pred(J) * ElSize], ElSize);
        Inc(I);
        Dec(J);
      END;
    UNTIL I > J;
    IF Links  < J THEN QSort(Links, J);
    IF Rechts > I Then QSort(I, Rechts);
  END;

BEGIN
  SError := GetArrayMem(ElSize, Tausch);
  IF SError <> SortOkay THEN Exit;

  ASeg  := Seg(APtr^);
  AOfs  := Ofs(APtr^);

(*$IFDEF VER40 *)
  InitSortFunc(Compf);
(*$ENDIF *)

  QSort(1,ASize);

END;

BEGIN
END.
(* ------------------------------------------------- *)
(*              Ende von HRS.PAS                     *)