program fox_sort;
{
(c)2003 Fox++ & Rulezz technologiez
http://kiiut.fatal.ru
mailto:kurepin@sura.ru
}
uses crt,dos;
const
     wait='Щаз погодьте...';
     afile='f0.bin';
type
    table=record
     name  : string[20];
     kol   : integer;
     time  : real;
     end;
type
    item=record
    key:integer;
end;
tfile=file of item;
var
   b     : array [1..100] of table;
   z     : item;                             {записи}
   i,j,xx: longint;                                         {индекс массива}
   num   : integer;
   sel   : char;                                           {выбор пункта меню}
   hour1,hour2,min1,min2,sec1,sec2,ms1,ms2 : word;
   time1,time2 : real;                 {начальное и конечное время сортировки}
procedure menu; forward;

procedure filegen;
{генератор бинарных файлов}
var
   f0:tfile;
   z:item;
   i:integer;
begin
writeln ('Генерация файла');
assign (f0,afile);
write ('# of tfile: ');
readln (num);
rewrite (f0);
randomize;
i:=0;
while i<=num do
begin
z.key:=random(32000);
write (f0,z);
inc(i);
end;
close (f0);
writeln ('Сгенерирован случайный файл из ',num,' элементов.');
readkey;
end;

procedure print;
var
   f0:tfile;
begin
assign (f0,afile);
reset (f0);
while not eof(f0) do
begin
read(f0,z);
write (z.key:5,' ');

end;
readkey;
clrscr;
end;

procedure result;
begin
clrscr;
writeln (#07,'Результаты сортировки');
writeln;
writeln ('Номер записи : ',xx);
writeln ('Алгоритм : ',b[xx].name);
writeln ('Число элементов : ',b[xx].kol);
writeln ('Время : ',b[xx].time:2:3,' с');
readkey;
end;

procedure prost;
var
  X,Y:array[1..100] of integer;
  Z:array[1..200] of integer;
  dx,dy,ix,iy,iz,i,j,G,N:integer;
begin
clrscr;
write('Введите длину массива Y ');
readln(dy);
writeln('Введите упорядоченый по возрастанию массив Y');
for i:=1 to dy do
read(Y[i]);
write('Введите длину массива X ');
readln(dx);
writeln('Введите упорядоченый по возрастанию массив X');
randomize;
for i:=1 to dx do
read(X[i]);
iy:=1;
ix:=1;
iz:=0;
writeln ('Запуск простого слияния');
inc(xx);
b[xx].name:='простое слияние';
b[xx].kol:=dx+dy;
gettime (hour1,min1,sec1,ms1);
while(ix<=dx) and (iy<=dy) do
if X[ix]<Y[iy] then
begin
inc(iz);
Z[iz]:=X[ix];
inc(ix);
end
else
begin
inc(iz);
Z[iz]:=Y[iy];
inc(iy);
end;
if ix>dx then
for i:=iy to dy do
begin
inc(iz);
Z[iz]:=Y[i];
end
else
for i:=ix to dx do
begin
inc(iz);
Z[iz]:=X[i];
end;
gettime (hour2,min2,sec2,ms2);
writeln ('Завершение простого слияния');
time1:=min1*60+sec1+ms1/100;
time2:=min2*60+sec2+ms2/100;
b[xx].time:=time2-time1;
result;
writeln('Полученый массив Z ');
for i:=1 to iz do
write(Z[i],' ');
readkey;
end;

procedure extl;
var
   f0:TFile;
procedure merge(k:integer;var f1,f2,g1,g2:TFile);
var outSwitch:boolean;
    Winner:integer;
    Used:array[1..2] of integer;
    Fin:array[1..2]of boolean;
    current:array[1..2]of Item;

procedure GetItem(i:integer);
begin

  if(Used[i]=k)or((i=1)and eof(f1))or((i=2)and eof(f2)) then Fin[i]:=True
  else if i=1 then read(f1,Current[1])
       else read(f2,Current[2]);
  Used[i]:=Used[i]+1;
end;

begin
  OutSwitch:=true;
  rewrite(g1);rewrite(g2);
  reset(f1);reset(f2);
  while (not eof(f1)) or (not eof(f2)) do
  begin
    Used[1]:=0;Used[2]:=0;
    Fin[1]:=false;Fin[2]:=false;
    GetItem(1);GetItem(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 Current[1].key<Current[2].key then Winner:=1
                else Winner:=2;
      if OutSwitch then write(g1,Current[Winner])
      else write(g2,Current[Winner]);
      GetItem(Winner);
    end;
    OutSwitch:=not OutSwitch;
  end;
  close(g1);close(g2);
  close(f1);close(f2);
end;

procedure MergeSort(var f0:TFile);
var f1,f2,g1,g2:TFile;
    i,n,k:integer;buf:Item;
    flag:boolean;
begin
  Assign(f1,'c:\F1Merge.itm');
  Assign(f2,'c:\F2Merge.itm');
  Assign(g1,'c:\G1Merge.itm');
  Assign(g2,'c:\G2Merge.itm');
  rewrite(f1);rewrite(f2);
  rewrite(g1);rewrite(g2);
  reset(f0);
  n:=0;
  while not eof(f0) do
  begin
    read(f0,buf);
    write(f1,buf);
    inc(n);
    if not eof(f0) then
    begin
      read(f0,buf);
      write(f2,buf);
      inc(n);
    end;
  end;
  flag:=true;k:=1;
  Close(f1);Close(f2);Close(f0);
  n:=trunc(ln(n)/ln(2))+1;
  for i:=1 to n do
  begin
    if flag then merge(k,f1,f2,g1,g2)
    else merge(k,g1,g2,f1,f2);
    flag:= not flag;
    k:=k*2;
  end;
  rewrite(f0);reset(g1);reset(f1);
  if not flag then
    while not eof(g1) do
    begin
      read(g1,buf);
      write(f0,buf);
    end
  else
    while not eof(f1) do
    begin
      read(f1,buf);
      write(f0,buf);
    end;
  Close(f0);Close(g1);Close(f1);
  {erase(f1);erase(g1);erase(f2);erase(g2);}
end;

begin
clrscr;
assign(f0,afile);
filegen;
clrscr;
writeln ('Запуск естественного слияния');
inc(xx);
b[xx].name:='естественное слияние';
b[xx].kol:=num;
gettime (hour1,min1,sec1,ms1);
MergeSort(f0);
gettime (hour2,min2,sec2,ms2);
writeln ('Завершение естественного слияния');
time1:=min1*60+sec1+ms1/100;
time2:=min2*60+sec2+ms2/100;
b[xx].time:=time2-time1;
b[xx].kol:=num;
result;
end;

procedure nextl;
const max=10000;
      maxint=32767;
type
    Item=record
    key:integer;
    end;
    TFile=file of Item;
var
   f0:TFile;

procedure NMerge(k:integer;var f1,f2,f3,f4,g1,g2,g3,g4:TFile);
var outSwitch:1..4;
    Winner:integer;
    Used:array[1..4] of integer;
    Fin:array[1..4]of boolean;
    Current:array[1..4]of Item;
    Tree:array[1..7]of Item;
    History:array[1..7]of integer;

procedure CompareTree;
begin
  if Tree[7].key<Tree[6].key then
  begin
    Tree[3]:=Tree[7];
    History[3]:=History[7];
  end
    else
    begin
      Tree[3]:=Tree[6];
      History[3]:=History[6];
    end;
  if Tree[5].key<Tree[4].key then
  begin
    Tree[2]:=Tree[5];
    History[2]:=History[5];
  end
    else
    begin
      Tree[2]:=Tree[4];
      History[2]:=History[4];
    end;
  if Tree[3].key<Tree[2].key then
  begin
    Tree[1]:=Tree[3];
    History[1]:=History[3];
  end
    else
    begin
      Tree[1]:=Tree[2];
      History[1]:=History[2];
    end;
end;

procedure NGetItem(i:integer);
begin
  if(Used[i]=k)or((i=1)and eof(f1))or((i=2)and eof(f2))or((i=3)and eof(f3))or((i=4)and eof(f4)) then
  begin
    Fin[i]:=True;
    Tree[8-i].key:=MaxInt;
  end
  else
    begin
      case i of
        1:read(f1,Current[1]);
        2:read(f2,Current[2]);
        3:read(f3,Current[3]);
        4:read(f4,Current[4]);
      end;
      Tree[8-i]:=Current[i];
      Used[i]:=Used[i]+1;
    end;
  CompareTree;
end;

procedure MakeTree;
var q:integer;
begin
  if not eof(f1) then
  begin
    read(f1,Tree[7]);
    History[7]:=1;
    Current[1]:=Tree[7];
  end;
  if not eof(f2) then
  begin
    read(f2,Tree[6]);
    History[6]:=2;
    Current[2]:=Tree[6];
  end;
  if not eof(f3) then
  begin
    read(f3,Tree[5]);
    History[5]:=3;
    Current[3]:=Tree[5];
  end;
  if not eof(f4) then
  begin
    read(f4,Tree[4]);
    History[4]:=4;
    Current[4]:=Tree[4];
  end;
  CompareTree;
end;

begin
  OutSwitch:=1;
  rewrite(g1);rewrite(g2);
  rewrite(g3);rewrite(g4);
  reset(f1);reset(f2);
  reset(f3);reset(f4);

  while (not eof(f1)) or (not eof(f2))or (not eof(f3))or (not eof(f4)) do
  begin
    Used[1]:=1;Used[2]:=1;Used[3]:=1;Used[4]:=1;
    Fin[1]:=false;Fin[2]:=false;Fin[3]:=false;Fin[4]:=false;
    MakeTree;
    while Tree[1].key<MaxInt do
    begin
      Winner:=History[1];

      case OutSwitch of
        1:write(g1,Current[Winner]);
        2:write(g2,Current[Winner]);
        3:write(g3,Current[Winner]);
        4:write(g4,Current[Winner]);
      end;
      NGetItem(Winner);
    end;
    if OutSwitch=4 then OutSwitch:=1
      else inc(OutSwitch);
  end;
  Close(g1);Close(g2);
  Close(f1);Close(f2);
  Close(g3);Close(g4);
  Close(f3);Close(f4);
end;

procedure NMergeSort(var f0:TFile);
var f1,f2,f3,f4,g1,g2,g3,g4:TFile;
    i,n,k:integer;buf:Item;
    flag:boolean;
begin
  assign(f1,'c:\F1Merge.itm');
  assign(f2,'c:\F2Merge.itm');
  assign(f3,'c:\F3Merge.itm');
  assign(f4,'c:\F4Merge.itm');
  assign(g1,'c:\G1Merge.itm');
  assign(g2,'c:\G2Merge.itm');
  assign(g3,'c:\G3Merge.itm');
  assign(g4,'c:\G4Merge.itm');
  rewrite(f1);rewrite(f2);
  rewrite(f3);rewrite(f4);
  rewrite(g1);rewrite(g2);
  rewrite(g3);rewrite(g4);
  reset(f0);
  n:=0;
  while not eof(f0) do
  begin
    read(f0,buf);
    write(f1,buf);
    inc(n);
    if not eof(f0) then
    begin
      read(f0,buf);
      write(f2,buf);
      inc(n);
    end;
    if not eof(f0) then
    begin
      read(f0,buf);
      write(f3,buf);
      inc(n);
    end;
    if not eof(f0) then
    begin
      read(f0,buf);
      write(f4,buf);
      inc(n);
    end;
  end;
  flag:=true;k:=1;
  Close(f1);Close(f2);Close(f0);
  Close(f3);Close(f4);
  n:=trunc(ln(n)/ln(4))+1;
  for i:=1 to n do
  begin
    if flag then NMerge(k,f1,f2,f3,f4,g1,g2,g3,g4)
    else NMerge(k,g1,g2,g3,g4,f1,f2,f3,f4);
    flag:= not flag;
    k:=k*4;
  end;
  rewrite(f0);reset(g1);reset(f1);
  if not flag then
    while not eof(g1) do
    begin
      read(g1,buf);
      write(f0,buf);
    end
  else
    while not eof(f1) do
    begin
      read(f1,buf);
      write(f0,buf);
    end;
  Close(f0);Close(g1);Close(f1);
  erase(f1);erase(g1);erase(f2);erase(g2);
  erase(f3);erase(g3);erase(f4);erase(g4);
end;

begin
clrscr;
filegen;
clrscr;
inc(xx);
b[xx].name:='многопутевое слияние';
b[xx].kol:=num;
gettime (hour1,min1,sec1,ms1);
assign(f0,afile);
writeln ('Запуск многопутевого слияния');
gettime (hour1,min1,sec1,ms1);
NMergeSort(f0);
gettime (hour2,min2,sec2,ms2);
writeln ('Завершение многопутевого слияния');
time1:=min1*60+sec1+ms1/100;
time2:=min2*60+sec2+ms2/100;
b[xx].time:=time2-time1;
result;
end;

procedure rating;
begin
clrscr;
writeln ('Рейтинг результатов');
writeln;
writeln ('╔════════════════════════════════╦════════╦═════════╗');
writeln ('║                       АЛГОРИТМ ║  ЧИСЛО ║  ВРЕМЯ  ║');
writeln ('╠════════════════════════════════╬════════╬═════════╣');
for i:=1 to xx do
begin
writeln ('║ ',b[i].name:30,' ║ ',b[i].kol:6,' ║   ',b[i].time:2:3,' ║');
end;
writeln ('╚════════════════════════════════╩════════╩═════════╝');
readkey;
end;

procedure menu;
begin
textcolor(2);
clrscr;
writeln;
writeln;
writeln;
writeln ('                        *** ВНЕШНИЕ СОРТИРОВКИ ***');
writeln ('                    *** Fox++  Rulezz technologiez ***');
writeln;
textcolor(11);
writeln ('                          1: Простое слияние');
writeln ('                          2: Естественное слияние');
writeln ('                          3: Многопутевое слияние');
writeln ('                          4: Таблица результатов');
writeln ('                          5: Вывод массива на экран');
writeln ('                          6: Выход');
sel:=readkey;
case sel of
'1':prost;
'2':extl;
'3':nextl;
'4':rating;
'5':print;
'6':exit;
end;
menu;
end;

BEGIN
menu;
END.