home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1989 / 06 / hitech / l_sort.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-03-29  |  10.1 KB  |  359 lines
  1. (* ------------------------------------------------------ *)
  2. (*                   L_SORT.PAS                           *)
  3. (*                                                        *)
  4. (* Das Programm demonstriert das Sortieren von Listen aus *)
  5. (* Einträgen mit mehreren Teilfeldern nach vorgegebenen   *)
  6. (* Prioritäten. Die wichtigste Aufgabe übernimmt die      *)
  7. (* Prozedur "LargeSort".                                  *)
  8. (*                                                        *)
  9. (*        (c) 1989  Jens Pionczewski  &  TOOLBOX          *)
  10. (*------------------------------------------------------- *)
  11. {$A+,B-,D+,F-,I-,L-,O-,R-,S-,V-}
  12.          (* Größtmögliche Geschwindigkeit, kleinster Code *)
  13. {$N-}                  (* Kein Coprozessor vorhanden  *)
  14. {$E-}                  (* Keine Emulation nötig  *)
  15.  
  16. {$M 65520,0,655360}    (* Maximaler Stack und Heap  *)
  17.  
  18. PROGRAM LargeSortDemo;
  19.  
  20. USES Dos,Crt;
  21.  
  22. CONST MaxElems              = 9000;
  23.       SubFieldStr  : STRING = '12345';
  24.       ListFileName : STRING = 'LISTFILE.TMP';
  25.  
  26. TYPE  SortRec      = RECORD
  27.                        Field_1 : CHAR;
  28.                        Field_2 : CHAR;
  29.                        Field_3 : CHAR;
  30.                        Field_4 : CHAR;
  31.                        Field_5 : CHAR
  32.                      END;
  33.       ElemType     = ^SortRec;
  34.  
  35. VAR   ElemList     : ARRAY [1..MaxElems] OF ElemType;
  36.       SortString   : STRING;
  37.       AnzElems     : LONGINT;
  38.       h, m, s, hs  : WORD;
  39.       ListFile     : FILE OF SortRec;
  40.             (* Diese Datei enthält die unsortierte Liste. *)
  41.       ch           : CHAR;
  42.  
  43. FUNCTION Vergleich (a, b : LONGINT; level : BYTE) : BOOLEAN;
  44. BEGIN
  45.   CASE SortString [level] OF
  46.     '1': Vergleich :=
  47.                ElemList[a]^.Field_1 <= ElemList[b]^.Field_1;
  48.     '2': Vergleich :=
  49.                ElemList[a]^.Field_2 <= ElemList[b]^.Field_2;
  50.     '3': Vergleich :=
  51.                ElemList[a]^.Field_3 <= ElemList[b]^.Field_3;
  52.     '4': Vergleich :=
  53.                ElemList[a]^.Field_4 <= ElemList[b]^.Field_4;
  54.     '5': Vergleich :=
  55.                ElemList[a]^.Field_5 <= ElemList[b]^.Field_5;
  56.   END;
  57. END;   (* Vergleich *)
  58.  
  59. PROCEDURE Tauschen (a, b : LONGINT);
  60. VAR HilfElem : ElemType;
  61. BEGIN
  62.   HilfElem     := ElemList [a];
  63.   ElemList [a] := ElemList [b];
  64.   ElemList [b] := HilfElem
  65. END;   (* Tauschen  *)
  66.  
  67. PROCEDURE QuickSort (anf, ende: LONGINT; level : BYTE);
  68. VAR i, j, trenn : LONGINT;
  69. BEGIN
  70.   i     := anf;
  71.   j     := ende;
  72.   trenn := (anf + ende) SHR 1;
  73.   REPEAT
  74.     WHILE (Vergleich (i, trenn, level) AND (i < ende)) DO
  75.       Inc (i);
  76.     WHILE (Vergleich (trenn, j, level) AND (j > anf)) DO
  77.       Dec (j);
  78.     IF i < j THEN
  79.       Tauschen (i,j)
  80.     ELSE IF i < trenn THEN
  81.       Tauschen (i,trenn)
  82.     ELSE IF j > trenn THEN
  83.       Tauschen (j,trenn)
  84.   UNTIL i >= j;
  85.   IF anf < j  THEN QuickSort (anf, j, level);
  86.   IF i < ende THEN QuickSort (i, ende, level)
  87. END;   (* QuickSort  *)
  88.  
  89. PROCEDURE LargeSort (left, right : LONGINT; level : BYTE);
  90. VAR Lindex, Rindex : LONGINT;
  91. BEGIN
  92.   QuickSort (left, right, level);
  93.   IF level < Length (SortString) THEN BEGIN
  94.     Lindex := left;
  95.     Rindex := Lindex;
  96.     WHILE Lindex < right DO BEGIN
  97.       WHILE (Vergleich (Rindex, Lindex, level) AND
  98.             (Rindex <= right)) DO
  99.         Inc (Rindex);
  100.       IF Lindex < Rindex - 1 THEN
  101.         LargeSort (Lindex, Rindex - 1, level + 1);
  102.       Lindex := Rindex
  103.     END;
  104.   END;
  105. END;   (* LargeSort  *)
  106.  
  107. PROCEDURE DelList;
  108. VAR i : LONGINT;
  109. BEGIN
  110.   WriteLn;
  111.   WriteLn ('  Deleting list ...');
  112.   FOR i := 1 TO AnzElems DO
  113.     Dispose (ElemList [i]);
  114.   AnzElems := 0
  115. END;   (* DelList  *)
  116.  
  117. PROCEDURE Initialize;
  118. VAR i, NewAnz : LONGINT;
  119. BEGIN
  120.   WriteLn;
  121.   WriteLn (AnzElems, ' entries were in list');
  122.   WriteLn;
  123.   Write ('Enter new number of entries : ');
  124.   ReadLn (NewAnz);
  125.   IF NewAnz > MaxElems THEN BEGIN
  126.     WriteLn;
  127.     WriteLn;
  128.     WriteLn ('Number too large.')
  129.   END ELSE BEGIN
  130.     DelList;
  131.     WriteLn;
  132.     IF NewAnz = 0 THEN
  133.       WriteLn ('No entries in list.')
  134.     ELSE BEGIN
  135.       AnzElems := NewAnz;
  136.       WriteLn (AnzElems,' entries in new list.');
  137.       WriteLn;
  138.       WriteLn ('Generating some random characters ...');
  139.       WriteLn;
  140.       FOR i:=1 TO AnzElems DO BEGIN
  141.         New (ElemList [i]);
  142.         WITH ElemList [i]^ DO BEGIN
  143.           Field_1 := CHAR (Random (26) + 65);
  144.           Field_2 := CHAR (Random (26) + 65);
  145.           Field_3 := CHAR (Random (26) + 65);
  146.           Field_4 := CHAR (Random (26) + 65);
  147.           Field_5 := CHAR (Random (26) + 65)
  148.         END;
  149.       END;
  150.       Assign (ListFile, ListFileName);
  151. {$I-}
  152.       Rewrite (ListFile);
  153. {$I+}
  154.       IF IOResult <> 0 THEN BEGIN
  155.         WriteLn;
  156.         WriteLn ('Cannot open file ' + ListFileName)
  157.       END ELSE BEGIN
  158.         WriteLn ('Creating file ', ListFileName, ' ...');
  159.         FOR i := 1 TO AnzElems DO
  160.           Write (ListFile, ElemList [i]^);
  161.         Close (ListFile);
  162.       END;
  163.     END;
  164.   END;
  165.   Delay (1500);
  166. END;   (* Initialize  *)
  167.  
  168. PROCEDURE SortSpecs (SubFieldString : STRING;
  169.                      VAR NewStr     : STRING);
  170. VAR i, Len : BYTE;
  171. BEGIN
  172.   Len := Length (SubFieldString);
  173.   Write ('Enter new priority-string (exmpl: "514") : ');
  174.   ReadLn (NewStr);
  175.   Delete (NewStr, Len + 1, 255);
  176. (* Länge auf Anzahl der Teilfelder eines Eintrages be-    *)
  177. (* grenzen und anschließend nicht erlaubte oder doppelt   *)
  178. (* vorhandene Zeichen löschen.                            *)
  179.   i := 1;
  180.   WHILE i <= Len DO
  181.     IF (Pos (NewStr [i], SubFieldString) = 0) OR
  182.        (Pos (NewStr [i], NewStr) < i) THEN BEGIN
  183.       Delete (NewStr, i, 1);
  184.       Dec (Len)
  185.     END ELSE Inc (i);
  186.   WriteLn;
  187.   WriteLn ('Priority-string is : ',NewStr);
  188.   Delay (1000);
  189. END;   (* SortSpecs  *)
  190.  
  191. PROCEDURE ListToScreen;
  192. VAR ch : CHAR;
  193.     i  : LONGINT;
  194. BEGIN
  195.   IF AnzElems = 0 THEN BEGIN
  196.     WriteLn;  WriteLn ('No entries in list.');
  197.     Delay (1000);
  198.   END ELSE BEGIN
  199.     ClrScr;
  200.     WriteLn ('      Field 1    Field 2    Field 3',
  201.              '    Field 4    Field 5');  WriteLn;
  202.     FOR i:=1 TO AnzElems DO
  203.       WITH ElemList [i]^ DO BEGIN
  204.         WriteLn (Field_1:9,  Field_2:11, Field_3:11,
  205.                  Field_4:11, Field_5:11);
  206.         IF ((i MOD 21) = 0) THEN BEGIN
  207.           WriteLn;
  208.           Write ('             Press any key ',
  209.                  'to continue, ESC to stop.');
  210.           ch := ReadKey;
  211.           ClrScr;
  212.           WriteLn ('      Field 1    Field 2    Field 3',
  213.                    '    Field 4    Field 5');   WriteLn;
  214.         END;
  215.         IF ch = #27 THEN Exit;
  216.         IF i = AnzElems THEN BEGIN
  217.           WriteLn;
  218.           WriteLn ('       Finished. Press any key.');
  219.           ch := ReadKey;
  220.         END;
  221.       END;
  222.   END;
  223. END;   (* ListToScreen  *)
  224.  
  225. PROCEDURE ListToFile;
  226. VAR FileName      : STRING;
  227.     SavedListFile : TEXT;
  228.     ch            : CHAR;
  229.     i             : LONGINT;
  230. BEGIN
  231.   WriteLn;
  232.   WriteLn;
  233.   Write ('Enter filename : ');
  234.   ReadLn (FileName);
  235.   WriteLn;
  236.   Assign (SavedListFile, FileName);
  237. {$I-}
  238.   Rewrite (SavedListFile);
  239. {$I+}
  240.   IF IOResult <> 0 THEN
  241.     WriteLn ('Error : Cannot open file  ',
  242.              FileName, ' .  Press any key.')
  243.   ELSE BEGIN
  244.     WriteLn ('Writing ', AnzElems, ' entries to file  ' +
  245.              FileName + ' ...');
  246.     WriteLn (SavedListFile, '      Field 1    Field 2',
  247.              '    Field 3    Field 4    Field 5');
  248.     FOR i := 1 TO AnzElems DO
  249.       WITH ElemList [i]^ DO
  250.         WriteLn (SavedListFile, Field_1:9, Field_2:11,
  251.                  Field_3:11, Field_4:11, Field_5:11);
  252.     WriteLn;  WriteLn;  WriteLn ('Finished.');
  253.     Delay (1000);
  254.     Close (SavedListFile);
  255.   END;
  256. END;   (* ListToFile  *)
  257.  
  258. PROCEDURE View_Save;
  259. VAR ch : CHAR;
  260. BEGIN
  261.   ClrScr;
  262.   WriteLn;  WriteLn ('    ESC Exit   (V)iew   (S)ave');
  263.   ch := ReadKey;
  264.   CASE ch OF
  265.     's','S' : ListToFile;
  266.     'v','V' : ListToScreen
  267.   END;
  268. END;   (* View_Save  *)
  269.  
  270. PROCEDURE ReadListFile;
  271. VAR i : LONGINT;
  272. BEGIN
  273.   WriteLn;
  274.   WriteLn ('Reading file ' + ListFileName + ' ...');
  275.   Assign (ListFile, ListFileName);
  276. {$I-}
  277.   Reset (ListFile);
  278. {$I+}
  279.  IF IOResult <> 0 THEN BEGIN
  280.    WriteLn;
  281.    WriteLn ('Cannot open file ' + ListFileName)
  282.  END ELSE BEGIN
  283.    FOR i := 1 TO AnzElems DO
  284.      Read (ListFile, ElemList [i]^);
  285.    Close (ListFile);
  286.  END;
  287. END;   (* ReadListFile  *)
  288.  
  289. PROCEDURE Arrange;
  290. VAR ch : CHAR;
  291. BEGIN
  292.   IF (SortString <> '') AND (AnzElems <> 0) THEN BEGIN
  293.     ReadListFile;
  294.     WriteLn;  WriteLn ('Sorting now ...');
  295.     SetTime (0, 0, 0, 0);
  296.     LargeSort (1, AnzElems, 1);
  297.     GetTime (h, m, s, hs);
  298.     WriteLn;
  299.     WriteLn ('Time used for sorting :   ',m,' : ',s,
  300.              ' : ',hs)
  301.   END ELSE BEGIN
  302.     WriteLn;
  303.     WriteLn;
  304.     IF AnzElems = 0 THEN
  305.       Write ('No entries found.')
  306.     ELSE
  307.       Write ('No specifications given.');
  308.     WriteLn (' List not sorted.')
  309.   END;
  310.   WriteLn;
  311.   WriteLn ('Press any key.');
  312.   ch := ReadKey
  313. END;   (* Arrange  *)
  314.  
  315. PROCEDURE Menu (VAR ch : CHAR);
  316. BEGIN
  317.   ClrScr;
  318.   WriteLn ('    ESC Quit   (I)nitialize  (S)ort',
  319.            'specifications   (A)rrange   (V)iew/save    ');
  320.   WriteLn ('-----------------------------------',
  321.            '--------------------------------------------');
  322.   WriteLn;  WriteLn;
  323.   WriteLn ('  Entries in list : ',AnzElems);
  324.   WriteLn;
  325.   WriteLn ('  SortSpecification : »',SortString,'«');
  326.   WriteLn;
  327.   WriteLn ('  Time used for last sorting :   ',h,' h  ',
  328.            m,' min  ',s,' s  ',hs,' 1/100');
  329.   WriteLn;
  330.   WriteLn ('  ─ ─ ─ ─ ─ ─ ─ ─ ─ ─ ─ ─ ─ ─ ─ ─ ─ ─ ─ ─ ─ ',
  331.            '─ ─ ─ ─ ─ ─ ─ ─ ─ ─ ─ ─ ─ ─ ─ ─ ─  ');
  332.   WriteLn;
  333.   ch := ReadKey
  334. END;   (* Menu  *)
  335.  
  336.  
  337. BEGIN  (* Hauptprogramm  *)
  338.   Randomize;
  339.   AnzElems := 0;
  340.   SortString := '';
  341.   h := 0; m := 0; s := 0; hs := 0;
  342.   REPEAT
  343.     Menu (ch);
  344.     CASE ch OF
  345.       'i','I' : Initialize;
  346.       's','S' : SortSpecs (SubFieldStr, SortString);
  347.       'v','V' : View_Save;
  348.       'a','A' : Arrange;
  349.     ELSE END;
  350.   UNTIL ch = #27;
  351.   DelList;
  352.   Assign (ListFile, ListFileName);
  353. {$I-}
  354.   Erase (ListFile)
  355. {$I+}
  356. END.
  357. (* ------------------------------------------------------ *)
  358. (*                Ende von L_SORT.PAS                     *)
  359.