home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / extra18 / grdlagen / sort / sort2.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1991-07-30  |  9.0 KB  |  314 lines
  1. Uses Dos,Crt,HRS;
  2. (*$M 65520,0,655360,R-,S-,I-,V-,B-,O-,A+ *)
  3. (*****************************************************************************)
  4. Type   String60 = String[60];
  5.  
  6.        ListTyp  = (StrTyp,WordTyp);
  7.  
  8.      StrListPtr = ^StringListe;
  9.  
  10.     StringListe = Record
  11.                     Next : StrListPtr;
  12.                     Info : String60;
  13.                   End;
  14.  
  15.     WordListPtr = ^WordListe;
  16.  
  17.       WordListe = Record
  18.                     Next : WordListPtr;
  19.                     W    : Word;
  20.                   End;
  21.  
  22. Const  MaxWord  = 65535;
  23.        Ret      =   #13;
  24.        Esc      =   #27;
  25.        CrLf     =  #10+Ret;
  26.        Chars    : SetOfChar = [Ret,Esc];
  27. (*****************************************************************************)
  28. Var  Proc       : SortFunc;
  29.      P,P2       : Pointer;
  30.      LSize      : Word;
  31.      LTyp       : ListTyp;
  32.      LT,C,Task  : Char;
  33.      Art        : Char;
  34.      ArtW       : Word;
  35.      I,Y        : Byte;
  36.      H1,H2,M1,
  37.      M2,S1,S2,
  38.      S100,S200  : Word;
  39.      Diff       : LongInt;
  40. (*****************************************************************************)
  41. Procedure DelZeile;
  42. Begin
  43.   GotoXY(1,WhereY);ClrEol;
  44. End;
  45. (*****************************************************************************)
  46. (* Die beiden folgenden Vergleichsfunktionen müßen,da sie über einen Zeiger  *)
  47. (* aufgerufen werden,unbedingt "FAR" compiliert werden.                      *)
  48. (*                                                                           *)
  49. (* Vergleichsfunktion für String                                             *)
  50. (*****************************************************************************)
  51. (*$F+ *)
  52. Function StringCheck(P1,P2:Pointer;Para:Word):CompTyp;
  53. Var Test  : CompTyp;
  54.     M     : LongInt;
  55.     S1,S2 : String60;
  56. Begin
  57.   S1 := StrListPtr(P1)^.Info;
  58.   S2 := StrListPtr(P2)^.Info;
  59.  
  60.   M  := Min(Length(S1),Length(S2));
  61.  
  62.   Test := Equal(StrListPtr(P1)^.Info[1],StrListPtr(P2)^.Info[1],M);
  63.   If Test = Gleich Then
  64.     If Not(Length(S1) = Length(S2)) Then
  65.       If Length(S1) > Length(S2) Then Test := Groesser
  66.                                  Else Test := Kleiner;
  67.  
  68.   If Para <> 0 Then
  69.   Begin
  70.     If Test = Groesser Then Test := Kleiner Else
  71.     If Test = Kleiner  Then Test := Groesser;
  72.   End;
  73.  
  74.   StringCheck := Test;
  75. End;
  76. (*****************************************************************************)
  77. (* Vergleichsfunktion für Word                                               *)
  78. (*****************************************************************************)
  79. Function WordCheck(P1,P2:Pointer;Para:Word):CompTyp;
  80. Var Test  : CompTyp;
  81.     W1,W2 : Word;
  82. Begin
  83.   W1 := WordListPtr(P1)^.W;
  84.   W2 := WordListPtr(P2)^.W;
  85.  
  86.   Test  := Gleich;
  87.   If W1 > W2 Then Test := Groesser;
  88.   If W2 > W1 Then Test := Kleiner;
  89.  
  90.   If Para <> 0 Then
  91.   Begin
  92.     If Test = Groesser Then Test := Kleiner Else
  93.     If Test = Kleiner  Then Test := Groesser;
  94.   End;
  95.  
  96.   WordCheck := Test;
  97. End;
  98. (*$F- *)
  99. (*****************************************************************************)
  100. Procedure ShowList(P:Pointer;C:Char);
  101. Var L : Word;
  102. Begin
  103.   L := 0;
  104.   While P <> Nil Do
  105.   Begin
  106.     Inc(L);
  107.     Write('  ',L:6,' : ');
  108.     If C = '1' Then
  109.     Begin
  110.       Writeln(StrListPtr(P)^.Info);
  111.       P := StrListPtr(P)^.Next;
  112.     End Else
  113.     Begin
  114.       Writeln(WordListPtr(P)^.W);
  115.       P := WordListPtr(P)^.Next;
  116.     End;
  117.     If KeyPressed Then
  118.     Begin
  119.       DummyRead;
  120.       DummyRead;
  121.     End;
  122.   End;
  123. End;
  124. (*****************************************************************************)
  125. (* Löscht durch P und Typ referenzierte Liste                                *)
  126. (*****************************************************************************)
  127. Procedure DelList(Var P:Pointer;Typ:ListTyp);
  128. Var L  : Word;
  129.     P2 : Pointer;
  130. Begin
  131.   L := 0;
  132.   While P <> Nil Do
  133.   Begin
  134.     P2 := P;
  135.     If Typ = STrTyp Then FreeMem(P,SizeOf(StringListe))
  136.                     Else FreeMem(P,SizeOf(WordListe));
  137.     P := WordListPtr(P2)^.Next;
  138.   End;
  139. End;
  140. (*****************************************************************************)
  141. (* Erzeugt Liste vom Typ "Typ" mit "Size" Elementen                          *)
  142. (*****************************************************************************)
  143. Procedure MakeList(Var Liste:Pointer;Typ:ListTyp;Size:Word);
  144. Var P1,P2,Head : Pointer;
  145.     L          : Word;
  146.     LSize      : Word;
  147. Begin
  148.   If Typ = StrTyp Then LSize := SizeOf(StringListe)
  149.                   Else LSize := SizeOf(WordListe);
  150.   GetMem(Head,LSize);
  151.   StrListPtr(Head)^.Next := Nil;
  152.   P1 := Head;
  153.  
  154.   For L := 2 To Size Do
  155.   Begin
  156.     GetMem(P2,LSize);
  157.     StrListPtr(P2)^.Next := StrListPtr(P1)^.Next;
  158.     StrListPtr(P1)^.Next := P2;
  159.   End;
  160.  
  161.   Liste := Head;
  162. End;
  163. (*****************************************************************************)
  164. (* Erzeugt eine Kopie der durch P und Typ referenzierten Liste               *)
  165. (*****************************************************************************)
  166. Function CopyList(P:Pointer;Typ:ListTyp;Size:Word):Pointer;
  167. Var P2,Head : Pointer;
  168. Begin
  169.   MakeList(P2,Typ,Size);
  170.   Head := P2;
  171.  
  172.   While P <> Nil Do
  173.   Begin
  174.     If Typ = StrTyp Then StrListPtr(P2)^.Info := StrListPtr(P)^.Info
  175.                     Else WordListPtr(P2)^.W := WordListPtr(P)^.W;
  176.     P  := StrListPtr(P)^.Next;
  177.     P2 := StrListPtr(P2)^.Next;
  178.   End;
  179.   CopyList := Head;
  180. End;
  181. (*****************************************************************************)
  182. (* Füllt Liste vom Typ "Typ" mit Zufallswerten                               *)
  183. (*****************************************************************************)
  184. Procedure FillList(P:Pointer;Typ:ListTyp);
  185. Var L : Word;
  186.     K : Byte;
  187.     S : String60;
  188. Function RandomStr:String60;
  189. Var K : Byte;
  190.     S : String60;
  191. Begin
  192.   S := '';
  193.   For K := 1 To Succ(Random(59)) Do S := S + Chr(Random(25)+66);
  194.   RandomStr := S;
  195. End;
  196. Begin
  197.   L := 0;
  198.   While P <> Nil Do
  199.   Begin
  200.     If Typ = StrTyp Then StrListPtr(P)^.Info := RandomStr
  201.                     Else WordListPtr(P)^.W := Random(MaxWord);
  202.     P := StrListPtr(P)^.Next;
  203.   End;
  204. End;
  205. (*****************************************************************************)
  206. (*    Hauptprogramm                                                          *)
  207. (*****************************************************************************)
  208. Begin
  209.   TextAttr := LightGray Shl 4;
  210.   ClrScr;
  211.  
  212.   Writeln('   SORTIERTEST      (c) H.Rüter 7/91',CrLf);
  213.  
  214.   TextAttr := LightGray;
  215.  
  216.   Randomize;
  217.  
  218.   Repeat
  219.     Window(2,2,79,24);
  220.     ClrScr;
  221.     Writeln(CrLf,' Listentyp         (1) = String (1..60 Zeichen)');
  222.     Writeln('                   (2) = Word-Zahlen');
  223.  
  224.     LT := GetChar(['1','2']);
  225.     LTyp := ListTyp(Ord(LT)-Ord('1'));
  226.  
  227.     (*$IFDEF VER40 *)
  228.     If LTyp = StrTyp Then Proc := @StringCheck
  229.                      Else Proc := @WordCheck;
  230.     (*$ELSE *)
  231.     If LTyp = StrTyp Then Proc := StringCheck
  232.                      Else Proc := WordCheck;
  233.     (*$ENDIF *)
  234.  
  235.     Write(CrLf,' Listenelemente      : ');
  236.     Readln(LSize);
  237.     MakeList(P,LTyp,LSize);
  238.     Write(' Zufallsgenerierung  : ');
  239.  
  240.     FillList(P,LTyp);
  241.     Writeln('√');
  242.  
  243.     P2 := CopyList(P,LTyp,LSize);
  244.  
  245.     Y := WhereY;
  246.  
  247.     Repeat
  248.       Window(2,Succ(Y),79,24);
  249.  
  250.       ClrScr;
  251.       Write(' Task                :  (Q)uick (A)ustausch Aus(w)ahl (E)infügen');
  252.  
  253.       Task := GetChar(['q','Q','a','A','w','W','e','E']);
  254.       DelZeile;
  255.       Write(' Sortierung          :  (A)ufsteigend A(b)steigend');
  256.  
  257.       Art := GetChar(['a','A','b','B']);
  258.       If Upcase(Art) = 'A' Then ArtW := 0
  259.                            Else ArtW := 1;
  260.       Writeln('  ',Upcase(Art));
  261.  
  262.       GetTime(H1,M1,S1,S100);
  263.  
  264.       Case UpCase(Task) Of
  265.        'Q' : Begin Write(' QuickSort    ');QuickSort(P,Einfach,Proc,ArtW);End;
  266.        'A' : Begin Write(' AustauschSort');AustauschSort(P,Einfach,Proc,ArtW);End;
  267.        'W' : Begin Write(' AuswahlSort  ');AuswahlSort(P,Einfach,Proc,ArtW);End;
  268.        'E' : Begin Write(' EinfuegeSort ');EinfuegeSort(P,Einfach,Proc,ArtW);End;
  269.       End;
  270.  
  271.       GetTime(H2,M2,S2,S200);
  272.       Diff := ((H2 * 360000 + M2 * 6000 + S2  * 100 + S200 ) -
  273.                (H1 * 360000 + M1 * 6000 + S1  * 100 + S100 ));
  274.  
  275.       Writeln('       : ',Diff div 100,',',Diff mod 100 ,' Sekunden',CrLf);
  276.       Write(' Liste zeigen : <RETURN>   nicht zeigen : <ESC>');
  277.  
  278.       C := GetChar(Chars);
  279.       DelZeile;
  280.  
  281.       If C = Ret Then
  282.       Begin
  283.         Writeln;
  284.         Window(2,10,79,24);
  285.         ShowList(P,LT);
  286.       End;
  287.  
  288.       Writeln;
  289.       Write(' Erneut sortieren : <RETURN>  Neue Liste oder Ende : <ESC>');
  290.       C := GetChar(Chars);
  291.       DelZeile;
  292.  
  293.       Write(' Bitte ein wenig warten');
  294.       If C = Ret Then
  295.       Begin
  296.         DelList(P,LTyp);
  297.         P := CopyList(P2,LTyp,LSize);
  298.       End;
  299.       DelZeile;
  300.  
  301.     Until C = Esc;
  302.  
  303.     DelList(P,LTyp);
  304.     DelLIst(P2,LTyp);
  305.  
  306.     Write(' Weiter : <RETURN>    Programmende : <ESC>');
  307.  
  308.  
  309.     C := GetChar(Chars);
  310.  
  311.  Until C = Esc;
  312.  
  313. End.
  314. (*****************************************************************************)