[Back to SORTING SWAG index]  [Back to Main SWAG index]  [Original]

{
From: pierre.tourigny@bbs.synapse.net (Pierre Tourigny)

> I'm looking for an external sort procedure in TP 6 / 7 which allows me
> to sort a file containing 20,000 records of the following type:
> RECORD
>   Phone : String[8];
>   L_Name : String[27];
>   F_Name : String[27];
> END;
> It must sort on Phone#. I could write it myself but I really need it
> in a hurry, so if anyone out there has an old sort procedure that I
> could modify to my own needs, I'd really apriciate it. Speed is of no
> importance.

Here's a modified merge sort that I used to sort a list of 260,000
words. It takes little memory and it's a fast O(NlogN) procedure. The
modification is that it goes external at k=1024 instead of at k=1.
}
program dictri;
{94-11-10, Pierre Tourigny, pierre.tourigny@bbs.synapse.net}
uses strings;

const
  k1 = 1024;
  strentree : string = 'c:\bp\bin\pas\diko2.dpt';
  strsortie : string = 'c:\bp\bin\pas\diko2.new';
type
  tmot = array[0..62] of char;
var
  source,ff1,ff2,fg1,fg2 : text;
  sourcebuf,ff1buf,ff2buf,fg1buf,fg2buf : array[0..4095] of char;
  k,maxmot : longint;
  fini : boolean;

procedure init;
begin
assign(source,strentree); settextbuf(source,sourcebuf); reset(source);
assign(ff1,'$f1$'); settextbuf(ff1,ff1buf); rewrite(ff1);
assign(ff2,'$f2$'); settextbuf(ff2,ff2buf); rewrite(ff2);
assign(fg1,'$g1$'); settextbuf(fg1,fg1buf); rewrite(fg1);
assign(fg2,'$g2$'); settextbuf(fg2,fg2buf); rewrite(fg2);
maxmot := 0;
fini := false;
end;

procedure passe1;
type
  tmots = array[0..k1] of tmot;
  pmots = ^tmots;
var
  i,j : integer;
  item : pmots;
  switch : boolean;

  Procedure inSort(item : pmots; last : integer);
  var
    i,j,span : integer;
  begin
  span := last shr 1;
  while span > 0 do begin
    for i := span to last-1 do begin
      for j := (i-span+1) downto 1 do
        if strcomp(item^[j],item^[j+span]) <= 0 then break
        else begin
          strcopy(item^[0],item^[j]);
          strcopy(item^[j],item^[j+span]);
          strcopy(item^[j+span],item^[0]);
          end;
      end;
    span := span shr 1;
    end;
  end;

begin
new(item);
fillchar(item^,sizeof(item^),0);
switch := true;
while not eof(source) do begin
  j := 0;
  for i := 1 to k1 do begin
    inc(j);
    readln(source,item^[i]);
    if eof(source) then break;
    end;
  inc(maxmot,j);
  insort(item,j);
  for i := 1 to j do if switch then writeln(ff1,item^[i])
    else writeln(ff2,item^[i]);
  switch := not switch;
  end;
dispose(item);
close(source);
writeln('Passe  1 termin,e    Nombre de mots: ',maxmot);
end;

procedure merge (lek : longint; var f1,f2,g1,g2 : text);
var
  outswitch : boolean;
  winner : integer;
  used : array[1..2] of longint;
  fin : array[1..2] of boolean;
  current : array[1..2] of tmot;
  numg1,numg2 : longint;

  procedure getrecord (i : integer);
  begin
  if (used[i] = lek) or ((i = 1) and eof(f1)) or
    ((i = 2) and eof(f2)) then fin[i] := true
  else begin
    inc(used[i]);
    if i = 1 then readln(f1,current[1])
    else readln(f2,current[2]);
    end;
  end;

begin
outswitch := true;
flush(g1); rewrite(g1);
flush(g2); rewrite(g2);
flush(f1); reset(f1);
flush(f2); reset(f2);
numg1 := 0; numg2 := 0;
while not eof(f1) or not  eof(f2) do begin
  fillchar(used,sizeof(used),0);
  fillchar(fin,sizeof(fin),false);
  fillchar(current,sizeof(current),0);
  getrecord(1); getrecord(2);
  while not fin[1] or not fin[2] do begin
    if fin[1] then winner := 2
    else if fin[2] then winner := 1
    else if strcomp(current[1],current[2]) < 0 then winner := 1
    else winner := 2;
    if outswitch then begin
      writeln(g1,current[winner]);
      inc(numg1);
      end
    else begin
      writeln(g2,current[winner]);
      inc(numg2);
      end;
    getrecord(winner);
    end;
  outswitch := not outswitch;
  end;
fini := numg2 = 0;
end;

procedure externe;
var
  i : integer;
  switch : boolean;
begin
i := 1;
k := k1;
switch := true;
while not fini {maxmot > k} do begin
  inc(i);
  write('Passe ',i:2,'  (k = ',k:7,')');
  if switch then merge(k,ff1,ff2,fg1,fg2)
  else merge(k,fg1,fg2,ff1,ff2);
  writeln(' termin,e');
  switch := not switch;
  k := k * 2;
  end;
close(ff2); erase(ff2);
close(fg2); erase(fg2);
close(ff1);
close(fg1);
assign(ff2,strsortie);
{$I-}
reset(ff2);
{$I+}
if ioresult = 0 then erase(ff2);
if switch then begin
  rename(ff1,strsortie);
  erase(fg1);
  end
else begin
  rename(fg1,strsortie);
  erase(ff1);
  end;
end;

begin {main}
init;
passe1;
externe;
end.

[Back to SORTING SWAG index]  [Back to Main SWAG index]  [Original]