home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / ZIPSORT.ZIP / ZIPSORT.PAS
Encoding:
Pascal/Delphi Source File  |  1986-08-14  |  4.8 KB  |  145 lines
  1. program ZipSort; { Version 1.1 }
  2.  
  3. {
  4.                    the sort procedure is a Turbo Pascal version of
  5.                    a basic program released by Mentat Software (c)
  6.                    R. F. Ashwell III 1830 Dover Rd, Dover Fl 33527
  7.  
  8.                                - ZipSort -  written by
  9.                                Jim Savold AT&T PC 6300
  10.                                2137  Cherrywood Circle
  11.                                Naperville, Il    60565
  12.  
  13.                    the sort is very fast - change the maxrec const
  14.                    to 1000 or more and time the result ( < 5 sec )
  15.                    - - - - - - - - - - - - - - - - - - - - - - - -
  16.                    modified Jan 16 to permit sorting on all or any
  17.                    part of a string - the change has increased the
  18.                    sort time slightly. ( 1000 records 5 to 7 sec )
  19.                    please send comments/improvements to Jim Savold
  20.                    - - - - - - - - - - - - - - - - - - - - - - - -
  21. }
  22.  
  23. const
  24.   len                                 = 11;   { length of sort record + 1 }
  25.   maxrec                              = 1000; { set as required           }
  26.  
  27. type
  28.   string_data                         = string [ 10 ]; { length of record }
  29.  
  30. var
  31.   sort_data                           : array [ 1..maxrec ] of string_data;
  32.   hold,pass                           : array [ 1..maxrec ] of integer;
  33.   part,indx,count,total               : integer;
  34.  
  35. procedure switch ( var a , b : integer );
  36. var
  37.   temp                                : string_data;
  38.  
  39. begin
  40.   temp := sort_data [ a ];
  41.   sort_data [ a ] := sort_data [ b ];
  42.   sort_data [ b ] := temp;
  43. end; { of switch procedure }
  44.  
  45. procedure sort;
  46. label                                   10,20,30,40,50,60,70,80;
  47.  
  48. var
  49.   areg,breg,creg,dreg,ereg,freg,xreg  : integer;
  50.  
  51. begin
  52.      areg := total; breg := 0; creg := 0; dreg := 1; ereg := 1; freg := 0;
  53. 10 : if ( areg - ereg ) < 9 then goto 70;
  54.      breg := ereg;
  55.      creg := areg;
  56. 20 : if ( copy ( sort_data [ breg ] , part , len - part ) ) >
  57.         ( copy ( sort_data [ creg ] , part , len - part ) ) then begin
  58.           switch ( creg , breg );
  59.           goto 60;
  60.           end;
  61. 30 : creg := creg - 1;
  62.        if creg > breg then goto 20;
  63.      creg := creg + 1;
  64. 40 : dreg := dreg + 1;
  65.        if ( breg - ereg ) < ( areg - creg ) then begin
  66.          hold [ dreg ] := creg;
  67.          pass [ dreg ] := areg;
  68.          areg := breg;
  69.          goto 10;
  70.          end;
  71.      hold [ dreg ] := ereg;
  72.      pass [ dreg ] := breg;
  73.      ereg := creg;
  74.      goto 10;
  75. 50 : if ( copy ( sort_data [ creg ] , part , len - part ) ) <
  76.         ( copy ( sort_data [ breg ] , part , len - part ) ) then begin
  77.           switch ( creg , breg );
  78.           goto 30;
  79.           end;
  80. 60 : breg := breg + 1;
  81.        if creg > breg then goto 50;
  82.      creg := creg + 1;
  83.      goto 40;
  84. 70 : if ( areg - ereg + 1 ) = 1 then goto 80;
  85.      for breg := ( ereg + 1 ) to areg do begin
  86.        for creg := ereg to ( breg - 1 ) do begin
  87.          freg := breg - creg + ereg - 1;
  88.          if ( copy ( sort_data [ freg ] , part , len - part ) ) >
  89.             ( copy ( sort_data [ freg + 1 ] , part , len - part ) ) then begin
  90.               xreg := freg + 1;
  91.               switch ( freg , xreg );
  92.               end;
  93.        end;
  94.      end;
  95. 80 : ereg := hold [ dreg ];
  96.      areg := pass [ dreg ];
  97.      dreg := dreg - 1;
  98.        if dreg = 0 then exit;
  99.      goto 10;
  100. end; { of sort procedure }
  101.  
  102. procedure make_string;
  103. var
  104.   ch                                  : string_data;
  105.   make                                : integer;
  106.  
  107. begin
  108.   randomize; ch := '';
  109.   for indx := 1 to total do begin
  110.     gotoxy(1,12); write( 'building sort string ' , indx:4 , ' of ', total );
  111.     for make := 1 to 10 do begin
  112.       ch := ch + chr( random ( 27 ) + 64 );
  113.     end;
  114.     sort_data [ indx ] := ch;
  115.     ch := '';
  116.   end;
  117. end; { of procedure to make a 'total' number of 10 random character strings }
  118.  
  119. begin { demonstration of ZipSort }
  120. clrscr;
  121.   gotoxy( 1 , 2 );
  122.   writeln( 'ZipSort Demonstration' );
  123.   writeln;
  124.   writeln( 'Enter the number of records to build and sort ( 1 - 1000 ) ',^g  );
  125.   readln ( total );
  126.   writeln;
  127.   writeln( 'Enter the position in the record to sort ( 1 - 10 ) ',^g  );
  128.   readln ( part );
  129.     make_string;
  130.       writeln;
  131.       writeln( '*** SORT START ***',^g );
  132.     sort;
  133.       writeln( '*** SORT ENDED ***',^g );
  134.       writeln;
  135.       writeln( 'sorted string list' );
  136.         count := 0;
  137.         for indx := 1 to total do begin { to display sorted strings }
  138.           count := count + 1;
  139.           if count = 8 then begin
  140.             writeln;
  141.             count := 1;
  142.             end;
  143.           write( ' ',sort_data [ indx ] );
  144.         end;
  145. end. { of demonstration program }