home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 13 / CDA13.ISO / cdactual / demobin / share / program / Pascal / ASORTS.ZIP / ASORTS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-02-28  |  7.4 KB  |  231 lines
  1. unit asorts;
  2. { General-purpose array manipulation routines }
  3. { Copyright 1991, by J. W. Rider }
  4.  
  5.  
  6. interface
  7.  
  8. { $define MONITOR} { <--- remove space before "$" to enable
  9.                           monitoring "qsort" }
  10. {$ifdef MONITOR}
  11.  
  12. var monitor : procedure; { for monitoring results of sort }
  13.  
  14. procedure nullmonitor; { to turn monitoring off }
  15.  
  16. {$endif}
  17.  
  18.  
  19. { "comparefunc" -- comparison function argument for "qsort", "bsearch"
  20.                    "lfind" and "lsearch" }
  21.  
  22. type comparefunc = function (var a,b):longint;
  23.  
  24.  
  25. { "qsort", "bsearch", "lfind" and "lsearch" are analogous to C functions of
  26.   the same names }
  27.  
  28. { quicksort the elements of an array }
  29. procedure qsort(var base; length_base, sizeof_element:word;
  30.                 f:comparefunc);
  31.  
  32. { binary search a sorted array for an element}
  33. function bsearch(var key,base; length_base, sizeof_element:word;
  34.                  f:comparefunc):word;
  35.  
  36. { linear search an array for an element }
  37. function lfind(var key,base; length_base, sizeof_element:word;
  38.                  f:comparefunc):word;
  39.  
  40. { linear search an array for an element; append if not found }
  41. function lsearch(var key,base; length_base, sizeof_element:word;
  42.                  f:comparefunc):word;
  43.  
  44.  
  45. { the remaining routines generally have no standard implementation in other
  46.   languages }
  47.  
  48. { binary search a sorted array for an element.  Return the index of
  49.   its location, or the negative of the index where it should be inserted }
  50. function bfind(var key,base; length_base, sizeof_element:word;
  51.                  f:comparefunc):longint;
  52.  
  53. { inserts an element into a sorted array. }
  54. function binsert(var key,base; length_base, sizeof_element:word;
  55.                  f:comparefunc):word;
  56.  
  57. { fill an array with an element }
  58. procedure fill(var key,destination; count, sizeof_element:word);
  59.  
  60. { fill a subarray with an element }
  61. procedure subfill(var key,destination;
  62.                   count, sizeof_key,sizeof_element:word);
  63.  
  64. { randomly permute the elements of an array }
  65. procedure shuffle(var base; length_base, sizeof_element:word);
  66.  
  67. { move subarray to array or array to subarray }
  68. procedure submove(var source,destination;
  69.                   count, sizeof_source, sizeof_destination:word);
  70.  
  71. { move subarray to subarray }
  72. procedure xsubmove(var source,destination;
  73.              count,sizeof_source,sizeof_destination,sizeof_move:word);
  74.  
  75. implementation
  76.  
  77. function bfind(var key,base; length_base, sizeof_element:word;
  78.                  f:comparefunc):longint;
  79. var b:array [0..$fffe] of byte absolute base; l,h,x,c:longint;
  80. begin
  81. if length_base>0 then begin
  82.    l:=0; h:=pred(length_base);
  83.    repeat
  84.        x:=(l+h) shr 1; c:=f(key,b[x*sizeof_element]);
  85.        if      c<0 then h:=pred(x)
  86.        else if c>0 then l:=succ(x)
  87.        else{if c=0 then}begin bfind:=succ(x); exit; end;
  88.        until l>h;
  89.    bfind:=-l; end
  90. else bfind:=0; end;
  91.  
  92.  
  93. function binsert(var key,base;length_base,sizeof_element:word;
  94.                    f:comparefunc):word;
  95. var b:array [0..$fffe] of byte absolute base; x:longint;
  96. begin
  97.    x:=bfind(key,base,length_base,sizeof_element,f);
  98.    if x<=0 then x:=-x else dec(x);
  99.    move(b[x*sizeof_element],b[succ(x)*sizeof_element],
  100.         (length_base-x)*sizeof_element);
  101.    move(key,b[x*sizeof_element],sizeof_element);
  102.    binsert:=succ(x); end;
  103.  
  104.  
  105. function bsearch(var key,base; length_base, sizeof_element:word;
  106.                  f:comparefunc):word;
  107. var c:longint;
  108. begin
  109.    c:=bfind(key,base,length_base,sizeof_element,f);
  110.    if c>0 then bsearch:=c
  111.    else bsearch:=0; end;
  112.  
  113.  
  114. procedure fill(var key,destination; count, sizeof_element:word);
  115. var b:array [0..$fffe] of byte absolute destination;
  116.     x,moved:word;
  117. begin if count>0 then begin
  118.    move(key,destination,sizeof_element);
  119.    moved:=1; dec(count); x:=sizeof_element;
  120.    while count>moved do begin
  121.          move(destination,b[x],x);
  122.          dec(count,moved); moved:=moved shl 1; x:=x shl 1; end;
  123.    move(destination,b[x],count*sizeof_element); end; end;
  124.  
  125.  
  126. function lfind(var key,base; length_base, sizeof_element:word;
  127.                  f:comparefunc):word;
  128. var b:array [0..$fffe] of byte absolute base; i,j:word;
  129. begin
  130.    j:=0;
  131.    for i:=1 to length_base do begin
  132.        if f(key,b[j])=0 then begin lfind:=i; exit end;
  133.        inc(j,sizeof_element); end;
  134.    lfind:=0; end;
  135.  
  136.  
  137. function lsearch(var key,base; length_base, sizeof_element:word;
  138.                  f:comparefunc):word;
  139. var b:array [0..$fffe] of byte absolute base; i:word;
  140. begin
  141.    i:=lfind(key,base,length_base,sizeof_element,f);
  142.    if i=0 then begin
  143.       move(key,b[length_base*sizeof_element],sizeof_element);
  144.       lsearch:=succ(length_base); end
  145.    else lsearch:=i; end;
  146.  
  147. {$ifdef MONITOR}
  148. { dummy "monitor" }
  149. procedure nullmonitor; begin pointer((@@monitor)^):=NIL end;
  150. {$endif}
  151.  
  152. procedure qsort(var base; length_base, sizeof_element:word;
  153.                f:comparefunc);
  154. var b: array[0..$fffe] of byte absolute base;
  155.     j:longint; x:word; y:byte;  { not preserved during recursion }
  156.  
  157. procedure sort(l,r: word);
  158. var i:longint; k:word;
  159. begin
  160.   i:=l*sizeof_element; j:=r*sizeof_element;
  161.   x:=((longint(l)+r) SHR 1)*sizeof_element;
  162.   while i<j do begin
  163.     while f(b[i],b[x])<0 do inc(i,sizeof_element);
  164.     while f(b[x],b[j])<0 do dec(j,sizeof_element);
  165.     if i<j then begin
  166.        for k:=0 to pred(sizeof_element) do begin
  167.            y:=b[i+k]; b[i+k]:=b[j+k]; b[j+k]:=y; end;
  168.        if i=x then x:=j else if j=x then x:=i;
  169.        {$ifdef MONITOR}
  170.        if @monitor<>nil then monitor;
  171.        {$endif}
  172.        end;
  173.     if i<=j then begin
  174.        inc(i,sizeof_element); dec(j,sizeof_element) end; end;
  175.   if (l*sizeof_element)<j then sort(l,j div sizeof_element);
  176.   if i<(r*sizeof_element) then sort(i div sizeof_element,r); end;
  177.  
  178. begin sort(0,pred(length_base)); end; {procedure qsort}
  179.  
  180.  
  181. procedure shuffle(var base; length_base, sizeof_element:word);
  182. var b: array[0..$fffe] of byte absolute base;
  183.     i,ix,j,jx,k:word; y:byte;
  184. begin if length_base>0 then
  185.   for i:=pred(length_base) downto 1 do begin
  186.       ix:=i*sizeof_element;
  187.       j:=random(succ(i));
  188.       if i<>j then begin
  189.          jx:=j*sizeof_element;
  190.          for k:=0 to pred(sizeof_element) do begin
  191.              y:=b[ix+k]; b[ix+k]:=b[jx+k]; b[jx+k]:=y; end; end; end; end;
  192.  
  193. procedure subfill(var key,destination;
  194.                   count, sizeof_key,sizeof_element:word);
  195. var b:array [0..$fffe] of byte absolute destination; i,j:word;
  196. begin
  197. j:=0;
  198. for i:=1 to count do begin
  199.    move(key,b[j],sizeof_key);
  200.    inc(j,sizeof_element); end; end;
  201.  
  202.  
  203. procedure submove(var source, destination;
  204.                   count, sizeof_source,sizeof_destination:word);
  205. var sm:word;
  206. begin if sizeof_source=sizeof_destination then
  207.   move(source,destination,count*sizeof_source)
  208. else begin
  209.   if sizeof_source>sizeof_destination then sm:=sizeof_destination
  210.   else                                     sm:=sizeof_source;
  211.   xsubmove(source,destination,
  212.            count,sizeof_source,sizeof_destination,sm); end; end;
  213.  
  214. procedure xsubmove(var source,destination;
  215.              count,sizeof_source,sizeof_destination,sizeof_move:word);
  216. var a:array [0..$fffe] of byte absolute destination;
  217.     b:array [0..$fffe] of byte absolute source;
  218.     i,j,k,sm:word;
  219. begin
  220.    j:=0; k:=0;
  221.    for i:=1 to count do begin
  222.        move(b[k],a[j],sizeof_move);
  223.        inc(j,sizeof_destination); inc(k,sizeof_source) end; end;
  224.  
  225. {$ifdef MONITOR}
  226. begin {initialization}
  227. nullmonitor;
  228. {$endif}
  229.  
  230. end.
  231.