Лабораторные работы_2 / LAB6 / LAB6

program Lab6_Zaharov;
uses crt;
type
    item = record
         key : integer;
    end;
    tape = file of item;
var
   c,a,b : tape;
   eor,fl : boolean;
   num : char;
   l : integer;
   x : item;
   f : text;

{Џа®жҐ¤га  ўлў®¤   ­®¬ «ЁЁ ­  нЄа ­}
procedure Anomaliya (text1, text2 : string; var p_repeat : boolean);
var  p_key : char;
     y : integer;
     i,k : byte;
begin
     clrscr;
     if p_repeat=true then k:=4 else k:=2;
     textcolor(k);
     y:=(82 - 4 - length (text1)) div 2;
     gotoxy (y,10); write ('Й'); for i:=1 to length (text1)+2 do write ('Н'); write ('»');
     gotoxy (y,11); write ('є '); textcolor (k+240); write (text1); textcolor (k); write (' є');
     gotoxy (y,12); write ('И'); for i:=1 to length (text1)+2 do write ('Н'); write ('ј');
     if length(text2)<>0
        then
        begin
             textcolor (8);
             y:=(82 - 8 - length (text2)) div 2;
             gotoxy (y,13); write ('Ъ'); for i:=1 to length (text2)+6 do write ('Д'); write ('ї');
             gotoxy (y,14); write ('і   ',text2,'   і');
             gotoxy (y,15); write ('А'); for i:=1 to length (text2)+6 do write ('Д'); write ('Щ');
        end;
     gotoxy(1,1);
     if p_repeat=true then
     repeat
           sound (800); delay (40000);
           nosound; delay (50000);
     until keypressed
     else  repeat until keypressed;
     k:=1; p_repeat:=true;
     gotoxy (60,20); textcolor (blue); write ('ЪДДДДДДДДДДДї');
     gotoxy (60,23); textcolor (blue); write ('АДДДДДДДДДДДЩ');
     repeat gotoxy (60,21); clreol;
           textcolor (15);
           textbackground (0);
           textcolor (blue); write ('і');
           textcolor (15);
           if k=1 then textbackground(blue) else textbackground(0);
           write (' ЏЋ‚’Ћђ€’њ ');
           textbackground (0);
           textcolor (blue); write ('і');
           textcolor (15);

           gotoxy (60,22); clreol;
           textcolor (15);
           textbackground (0);
           textcolor (blue); write ('і');
           textcolor(15);
           if k=2 then textbackground(blue) else textbackground(0);
           write (' ‡Ђ‚…ђ€’њ ');
           textbackground (0);
           textcolor (blue); write ('і');
           textcolor (15);
           repeat
                 p_key:=readkey;
           until (p_key=chr(72)) or (p_key=chr(80)) or (p_key=chr(13));
           if ((p_key=chr(72)) or (p_key=chr(80))) and (k=1)
              then begin k:=2; p_repeat:=false; end
              else              if ((p_key=chr(72)) or (p_key=chr(80))) and (k=2)
                 then begin k:=1; p_repeat:=true; end
                 else
                 if p_key=chr(13)
                    then k:=3;
    until (k=3);
    clrscr;
end;

{ЏҐаҐбл«Є  н«Ґ¬Ґ­в  Ё§ е ў г}
procedure Copy (var x,y : tape);
var buf,buf1 : item;
begin
     read (x,buf);
     write (y,buf);
     if not eof(x) then
     begin
          {‡ Ј«п¤лў ­ЁҐ ўЇҐаҐ¤}
          read (x,buf1);
          eor:=buf.key>buf1.key;
          seek(x,filepos(x)-1);
     end
     else eor:=true;
end;

{ЏҐаҐЇЁбм ®¤­®© бҐаЁЁ Ё§ е ў г}
procedure CopyRun (var x,y : tape);
begin
     repeat
           Copy (x,y);
     until eor;
end;

{‘«Ёп­ЁҐ бҐаЁ© Ё§   Ё b ў б}
procedure MergeRun;
var bufA, bufB : item;
begin
     repeat
           read (a,bufA);
           read (b,bufB);
           if bufA.key<bufB.key then
           begin
                seek (a,filepos(a)-1);
                seek (b,filepos(b)-1);
                Copy (a,c);
                if eor then
                   CopyRun (b,c);
           end
           else
           begin
                seek (a,filepos(a)-1);
                seek (b,filepos(b)-1);
                Copy (b,c);
                if eor then
                   CopyRun (a,c);
           end;
     until eor;
end;

{Ё§ a Ё b ў c}
procedure Merge;
begin
     repeat
           MergeRun;
           l:=l+1;
     until (eof (b) or eof (a));
     while not eof (a) do
     begin
          CopyRun (a,c);
          l:=l+1;
     end;
     while not eof (b) do
     begin
          CopyRun (b,c);
          l:=l+1;
     end;
end;

{Ё§ б ў a Ё b}
procedure Distribute;
begin
     repeat
           CopyRun (c,a);
           if not eof (c) then
              CopyRun (c,b);
     until eof (c);
end;

{‘®авЁа®ўЄ  ҐбвҐб⢥­­л¬ б«Ёп­ЁҐ¬}
procedure NaturalMerge;
begin
     repeat
           rewrite (a);
           rewrite (b);
           reset (c);
           Distribute;
           l:=0;
           reset (a);
           reset (b);
           rewrite (c);
           Merge;
     until l=1;
end;

{ѓ« ў­ п Їа®Ја ¬¬ }
begin
     repeat
           clrscr;
           writeln;
           writeln ('               ‹ Ў®а в®а­ п а Ў®в  # 7');
           writeln ('                 ‚­Ґи­пп б®авЁа®ўЄ .');
           writeln;
           write ('‚ўҐ¤ЁвҐ ­®¬Ґа д ©«  (1 Ё«Ё 2) >>> ');
           readln (num);
           if (num<>'1') and (num<>'2') then
           begin
                fl:=true;
                Anomaliya ('‚­Ё¬ ­ЁҐ! ЋиЁЎЄ !','€бЄ®¬л© д ©« ­Ґ бгйҐбвўгҐв',fl);
           end
           else
           begin
                assign (a,'H:\LAB6\a'+num+'.dat');
                assign (b,'H:\LAB6\b'+num+'.dat');
                assign (c,'H:\LAB6\c'+num+'.dat');
                assign (f,'H:\LAB6\f'+num+'.txt');
                reset (f);
                rewrite (c);
                writeln ('„® б®авЁа®ўЄЁ:');
                while not eof (f) do
                begin
                     read (f,x.key);
                     write (c,x);
                     write (x.key,' ');
                end;
                writeln;
                NaturalMerge;
                writeln ('Џ®б«Ґ б®авЁа®ўЄЁ:');
                reset (c);
                while not eof (c) do
                begin
                     read (c,x);
                     write (x.key,' ');
                end;
                fl:=false;
                readln;
                Anomaliya ('Џа®Ја ¬¬  ўлЇ®«­Ґ­  гбЇҐи­®.','',fl);
                close (a);
                close (b);
                close (c);
                close (f);
           end;
     until fl=false;
end.