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

Pascal/Delphi Source File | 1992-01-28 | 5.6 KB | 211 lines

(* ------------------------------------------------- *)
(*                    SORT1.PAS                      *)
(*             Demonstration zur Unit HRS            *)
(* ------------------------------------------------- *)
PROGRAM Sort1;

(*$M 65520,0,655360,R-,S-,I-,V-,B-,O-,A+ *)

(* ------------------------------------------------- *)
(* Maximaler Heap und Stack. Die Quicksort-Routine   *)
(* ist rekursiv, deshalb hohe Belastung des Stack.   *)
(* Die Compiler-Optionen sorgen für höchstmögliche   *)
(* Geschwindigkeit des Programms.                    *)
(* ------------------------------------------------- *)

USES Dos, Crt, HRS;

TYPE
  DirArray  = ARRAY [1..112] Of SearchRec;
  SPtr      = ^SearchRec;

CONST
  ESC       = #27;
  Ret       = #13;

VAR
  DArray    : DirArray;
  DPtr      : Pointer;
  Direc     : STRING;
  Proc      : SortFunc;
  Size      : WORD;
  C, LT     : CHAR;

(*$F+ *)
  FUNCTION Check(P1, P2 : Pointer;
                 Para : WORD) : CompTyp;
  (* Vergleichsroutine für SearchRec-Typ *)
  VAR
     M       : Byte;
     S1, S2  : STRING [12];
     Ext1,
     Ext2    : STRING [4];
     Po1,
     Po2     : BYTE;
     Test    : CompTyp;
  BEGIN
    S1  := SPtr(P1)^.Name;
    S2  := SPtr(P2)^.Name;
    Po1 := Pos('.', S1);
    Po2 := Pos('.', S2);

    IF ((Po1 > 0) AND (Po2 > 0)) THEN BEGIN
        (* Erst die Extension *)
      Ext1 := Copy(S1, Succ(Po1), Length(S1) - Po1);
      Ext2 := Copy(S2, Succ(Po2), Length(S2) - Po2);

      M    := Min(Length(Ext1), Length(Ext2));
      Test := Equal(Ext1[1], Ext2[1], M);

      IF Test = Gleich THEN BEGIN
        IF Length(Ext1) > Length(Ext2) THEN
          Test := Groesser;
        IF Length(Ext1) < Length(Ext2) THEN
          Test := Kleiner;
      END;

      IF Test = Gleich THEN BEGIN
          (* Dann der "Vorname" *)
        Delete(S1, Po1,Length(S1) - Succ(Po1));
        Delete(S2, Po2,Length(S2) - Succ(Po2));
        M := Min(Length(S1), Length(S2));

        IF M > 0 THEN BEGIN
          Test := Equal(S1[1],S2[1],M);
          IF Test = Gleich THEN BEGIN
            IF Length(S1) > Length(S2) THEN
              Test := Groesser;
            IF Length(S1) < Length(S2) THEN
              Test := Kleiner;
          END;
        END ELSE BEGIN
          IF S1 = '' THEN Test := Kleiner;
          IF S2 = '' THEN Test := Groesser;
          IF (S1 = '') AND (S2 = '') THEN
            Test := Gleich;
        END;
      END;
    END ELSE IF ((Po1 = 0) AND (Po2 = 0)) THEN BEGIN
      (* Nochmal der "Vorname" *)
      M := Min(Length(S1),Length(S2));
      IF M > 0 THEN
        Test := Equal(S1[1], S2[1], M)
      ELSE BEGIN
        IF S1 = '' THEN Test := Kleiner;
        IF S2 = '' THEN Test := Groesser;
        IF (S1 = '') AND (S2 = '') THEN Test := Gleich;
      END;
    END ELSE IF Po1 > 0 THEN
      Test := Groesser
    ELSE IF Po2 > 0 THEN
      Test := Kleiner;

      (* Bei Gleichheit nun Vergleich von Größe, Zeit
         und Attribut der Dateien                    *)

    IF Test = Gleich THEN
      IF SPtr(P1)^.Size > SPtr(P2)^.Size THEN
        Test := Groesser
      ELSE IF SPtr(P2)^.Size > SPtr(P1)^.Size THEN
        Test := Kleiner
      ELSE Test := Gleich;

    IF Test = Gleich THEN
      Test := Equal(SPtr(P1)^.Time,
                    SPtr(P2)^.Time, SizeOf(LongInt));
    IF Test = Gleich THEN
      Test := Equal(SPtr(P1)^.Attr,
                    SPtr(P2)^.Attr, SizeOf(Byte));

    (* Reihenfolge umkehren *)
    IF Para = 1 THEN BEGIN
      IF Test = Groesser THEN
        Test := Kleiner
      ELSE IF Test = Kleiner THEN
        Test := Groesser;
    END;

    Check := Test;
  END;
(*$F- *)

  PROCEDURE MakeArray(    Dir   : STRING;
                      VAR Liste : DirArray;
                      VAR Size  : WORD);
    (* Das Sortierarray wird mit SearchRecs aus dem
       Directory Dir gefüllt        *)
  VAR
    F : SearchRec;
  BEGIN
    Size := 0;
    FindFirst(Dir+'\*.*', AnyFile, F);

    WHILE DosError = 0 DO BEGIN
      IF (F.Attr AND VolumeId = 0) AND
         (F.Attr AND Directory = 0) THEN BEGIN
        Inc(Size);
        Liste[Size] := F;
      END;
      FindNext(F);
    END;
  END;

  PROCEDURE ShowArray(Liste : DirArray; Size : WORD);
  VAR
    L : WORD;
    D : DateTime;
  BEGIN
    L := 0;
    WHILE L <> Size DO BEGIN
      Inc(L);
      WITH Liste[L] DO BEGIN
        UnPackTime(Time,D);
        Writeln(' ', Name, ' ':13 - Length(Name),
                '  ', D.Day:2, '.', D.Month:2,
                '.', D.Year, '  ', D.Hour:2,
                '.', D.Min:2, ',', D.Sec:2,
                '  ', Size:8);
      END;
      IF KeyPressed THEN BEGIN
        DummyRead;
        DummyRead;
      END;
    END;
  END;

BEGIN
  Proc     := Check;
  DPtr     := @DArray;
  TextAttr := LightGray;
  ClrScr;
  Writeln('      SORTIERTEST');
  Window(2,2,79,24);
  TextAttr := Blue SHL 4;

  REPEAT
    ClrScr;

    Write(' Directory   : ');
    ReadLn(Direc);
    IF Direc = '' THEN GetDir(0, Direc);

    WriteLn(' Aufsteigend :  (1)');
    WriteLn(' Absteigend  :  (2)');
    C := GetChar(['1','2']);

    MakeArray(Direc, DArray, Size);

    IF C = '1' THEN
      ArraySort(DPtr,Size,SizeOf(SearchRec),Proc,0)
    ELSE
      ArraySort(DPtr,Size,SizeOf(SearchRec),Proc,1);

    ShowArray(DArray, Size);
    WriteLn(' Weiter mit <RETURN>   Ende mit <ESC>');
    C := GetChar([Ret, Esc]);

  UNTIL C = Esc;
END.
(* ------------------------------------------------- *)
(*                Ende von SORT1.PAS                 *)