home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / SORT2.ZIP / BTSORT.INC < prev    next >
Encoding:
Text File  |  1993-01-04  |  7.4 KB  |  203 lines
  1. { Routines to implement a binary tree structure of all input lines }
  2. { Copyright 1988,1989, by J. W. Rider }
  3.  
  4. procedure firstline;
  5. { makes the first record in the btree current }
  6. { THIS PROCEDURE WORKS INDEPENDENTLY OF THE STATE OF FIRSTNODE }
  7. begin if root<>nil then begin
  8.    current:=root; while current^.l<>nil do current:=current^.l;
  9.    linefound:=true; end
  10. else begin current:=nil; linefound:=false; end; end;
  11.  
  12. procedure nextline;
  13. { makes current the record following current record }
  14. begin if current<>nil then
  15.    if current^.r<>nil then begin current:=current^.r;
  16.       while current^.l<>nil do current:=current^.l;
  17.       linefound:=true; end
  18.    else begin while (current^.u<>nil) and (current^.u^.r=current) do
  19.          current:=current^.u;
  20.       if current^.u<>nil then begin
  21.          current:=current^.u; linefound:=true; end
  22.       else begin current:=nil; linefound:=false; end end
  23. else linefound:=false; end;
  24.  
  25. procedure writenode;
  26. { Writes the data corresponding to a single node to standard output }
  27. { Called either by "prunefirst" or "retrieveln" }
  28. var i,j: longint; key: string; begin
  29. if unique then j:=1 else j:=current^.c;
  30. for i:=1 to j do
  31.    if keysonly then begin
  32.       key:=copy(current^.d,current^.ks,current^.kl);
  33.       if not sensecase then key:=lcase(key);
  34.       if ancase then key:=anstr(key);
  35.       writeln(key); end
  36.    else writeln(current^.d); end; { procedure writenode }
  37.  
  38. procedure storeln(var s:string);
  39. { stores a btree record for each line of input }
  40. var storedone:boolean; newline:lp; positnum,lengthnum: integer;
  41.  
  42. function lesskey:boolean;
  43. { returns true if the key of new line is strictly less than the key
  44.   of the current line record }
  45. var rkey: string;
  46. begin if sortnumeric then lesskey:= (kn<current^.k) xor reversed
  47. else begin rkey:=copy(current^.d,current^.ks,current^.kl);
  48.    if ancase then rkey:=anstr(rkey);
  49.    if sensecase then lesskey:=(key < rkey) xor reversed
  50.    else lesskey:=(key < lcase(rkey)) xor reversed;
  51.    end; end; { function storeln.lesskey }
  52.  
  53. procedure balancetree;
  54. { improves search performance by moving the current node to the
  55.   root position }
  56. begin
  57. if current^.l=nil then begin
  58.    current^.l:=root; root^.u:=current; root:=current;
  59.    if current^.u^.r=current then
  60.       current^.u^.r:=nil
  61.    else current^.u^.l:=nil;
  62.    current^.u:=nil; end
  63. else if current^.r=nil then begin
  64.    current^.r:=root; root^.u:=current; root:=current;
  65.    if current^.u^.l=current then
  66.       current^.u^.l:=nil
  67.    else current^.u^.r:=nil;
  68.    current^.u:=nil; end; end;
  69.  
  70. procedure findline; var treedepth:longint;
  71. { find the line that matches the last input }
  72. begin linefound:=true;
  73.  
  74. { Btree performance was SO BAD for partially sorted input that
  75.   this routine now checks to see if the input was already partially
  76.   sorted. }
  77.  
  78. {check if its last -- most likely for partially sorted input }
  79. if lastnode<>nil then begin
  80.    current:=lastnode; islast:=true; isfirst:=lastnode=firstnode;
  81.    if lastnode^.d=s then exit
  82.    else if not lesskey then
  83.       begin linefound:=false; exit; end; end;
  84.  
  85. {check if its first -- most likely for reversed sorted input}
  86. if firstnode<>nil then begin
  87.    current:=firstnode; isfirst:=true; islast:=lastnode=firstnode;
  88.    if firstnode^.d=s then exit
  89.    else if lesskey then
  90.       begin linefound:=false; exit; end; end;
  91. isfirst:=false;
  92.  
  93. { If it doesn't belong on either end, do a binary tree search on
  94.   the rest of the lines }
  95. if root<>nil then begin
  96.      current:=root; linefound:=true; treedepth:=0;
  97.      islast:=true; isfirst:=true;
  98.      while linefound do
  99.         if current^.d=s then exit
  100.         else if lesskey then begin
  101.            islast:=false; inc(treedepth);
  102.            if isfirst and (current^.r=nil) and (treedepth>2)
  103.               and (treedepth>(nodecount div 2)) then begin
  104.               balancetree; treedepth:=0; end;
  105.            if current^.l<>nil then current:=current^.l
  106.            else linefound:=false; end
  107.         else begin
  108.            isfirst:=false; inc(treedepth);
  109.            if islast and (current^.l=nil) and (treedepth>2)
  110.               and (treedepth>(nodecount div 2)) then begin
  111.               balancetree; treedepth:=0; end;
  112.            if current^.r<>nil then current:=current^.r
  113.            else linefound:=false; end; end
  114. else begin current:=nil; linefound:=false end
  115. end; { procedure storeln.findline }
  116.  
  117. function incrline:boolean;
  118. { if line already exists, just increment its count '.c' }
  119. begin findline; if linefound then inc(current^.c);
  120. incrline:=linefound; end; { function storeln.incrline }
  121.  
  122. procedure prunefirst;
  123. { eliminates the first line record from the btree.  This routine is
  124.   called only if there is not enough memory to hold all to sorted
  125.   on the heap at once. }
  126. var oldcur:lp; i:integer;
  127. begin oldcur:=current; current:=firstnode;
  128. writenode; dec(nodecount);
  129. if current^.r<>nil then current^.r^.u:=current^.u;
  130. if current^.u<>nil then
  131.    current^.u^.l:=current^.r
  132. else root:=current^.r;
  133. if oldcur=current then begin oldcur:=current^.u; isfirst:=true; end;
  134. freemem(current,length(current^.d)+1+sizeof(lh));
  135. firstline; firstnode:=current; current:=oldcur;
  136. end; { procedure storeln.prunefirst }
  137.  
  138. begin { procedure storeln }
  139. storedone:=false;
  140.  
  141. { generate the key for the new line }
  142. if usefields then begin
  143.    nlks:=findfield(keycol,s); nlkl:=findfield(keycol2,s);
  144.    nlkl:=nlkl-nlks+1; end
  145. else begin
  146.    if length(s)<keycol then nlks:=length(s)+1
  147.    else nlks:=keycol;
  148.    if length(s)<keycol2 then nlkl:=length(s)-nlks+1
  149.    else nlkl:=keycol2-nlks+1; end;
  150.  
  151. if ignoreblanks then
  152.    while (nlkl<>0) and (s[nlks] in [^I,' ']) do begin
  153.       inc(nlks);dec(nlkl); end;
  154.  
  155. key:=copy(s,nlks,nlkl);
  156. if sortnumeric then begin
  157.    positnum:=posnum(key,lengthnum); nlkl:=lengthnum;
  158.    if positnum>0 then begin
  159.       nlks:=nlks+positnum-1;
  160.       key:=copy(key,positnum,nlkl); end
  161.    else begin nlkl:=0; key:=''; end;
  162.    kn:=bval(key); end
  163. else if not sensecase then key:=lcase(key);
  164. if ancase then key:=anstr(key);
  165.  
  166. { if the line already exists, just increment the count c }
  167. if not incrline then begin
  168.  
  169.    { if there is not enough room to store the line, }
  170.    while (maxavail<(length(s)+1+grain+sizeof(lh))) and (not storedone) do
  171.  
  172.       { output the new line if it would be first anyhow }
  173.       if isfirst then begin writeln(s); storedone:=true;
  174.          if earlyout then sorterror:=true;
  175.          earlyout:=true; end
  176.  
  177.       { output the first line record and retreive space until room exists }
  178.       else begin prunefirst; earlyout:=true; end;
  179.  
  180.    { allocate room for the line if it has not been output }
  181.    if not storedone then begin getmem(newline,length(s)+1+sizeof(lh));
  182.       newline^.c:=1; newline^.r:=nil; newline^.l:=nil; inc(nodecount);
  183.  
  184.       { store the line into the btree }
  185.       newline^.d:=s; newline^.u:=current; newline^.k:=kn;
  186.       newline^.ks:=nlks; newline^.kl:=nlkl;
  187.       if current=nil then findline;
  188.       if current<>nil then
  189.          if lesskey then begin current^.l:=newline;
  190.             if current=firstnode then firstnode:=newline; end
  191.          else begin current^.r:=newline;
  192.             if current=lastnode then lastnode:=newline; end
  193.       else begin
  194.          root:=newline; firstnode:=newline; lastnode:=newline; end;
  195.       sorterror:=sorterror or (isfirst and earlyout); end; end;
  196.  
  197. end; {procedure storeln}
  198.  
  199. procedure retrieveln; { dumps the rest of the btree to standard output }
  200. var i:integer;
  201. begin firstline; while linefound do begin writenode; nextline; end; end;
  202.  
  203.