Uses DOS;
Type
  Ftype = integer;
  FDAT  = file of Ftype;
Var
  H1, M1,
  H2, M2,
  S1, S2,s3     : Word;
  Ftext         : text;
  A,B,C,D,T     : ^FDAT;
  curA, prevA,
  curB, prevB   : Ftype;
  sendA,sendB,
  fendA,fEndB,
  ns            : boolean;
  TLen          : longint;
{------------------------------}

Function NewA : FType;
var
 ret : Ftype;
begin
  If EOF(A^) then
   begin
    FendA := true;
    NewA := -1;
   end
  else
   begin
    Read(A^,ret);
    NewA := ret;
   end;
end;

Function NewB : FType;
var
 ret : Ftype;
begin
  If EOF(B^) then
   begin
    FendB := true;
    NewB := -1;
   end
  else
   begin
    Read(B^,ret);
    NewB := ret;
   end;
end;

Procedure Init;
var
  cur    : Ftype;
  curw   : boolean;
begin
  New(A);
  New(B);
  New(C);
  New(D);
  Assign(A^,'file1.dat');
  Assign(B^,'file2.dat');
  Assign(C^,'file3.dat');
  Assign(D^,'file4.dat');
  Rewrite(A^);
  Rewrite(B^);
  Rewrite(C^);
  Rewrite(D^);
  {--------}
  curw := true;
  Assign(Ftext,'input.txt');
  Reset(Ftext);
  Tlen := 0;
  repeat
    read(Ftext,cur);
    if curw then Write(A^,cur) else Write(B^,cur);
    curw := not curw;
    inc(Tlen);
  until EOF(Ftext);
  Dec(Tlen);
  Reset(A^);
  Reset(B^);
  Close(Ftext);
end;{Init}
{---------------}
BEGIN
  Init;
  WriteLn('Начинаем сортировку ',Tlen,' элементов');
  GetTime(H1,M1,S1,S2);
  WriteLn('Текущее время: ',H1,' часов ',M1,' минут ',S1,' секунд');
  preva := -maxint;
  prevb := preva;
  repeat
    ns := true;
    curA := NewA;
    curB := NewB;
    fendA := False;
    fendB := false;
    repeat
      sendA := false;
      sendB := false;
      if (not fendA) and (not fendB) then
      repeat
        if curA < curB then
         begin
           Write(C^,curA);
           prevA := curA;
           curA  := newA;
           if curA < prevA then sendA := true;
         end
        else
         begin
           Write(C^,curB);
           prevB := curB;
           curB  := newB;
           if curB < prevB then sendB := true;
         end
      until sendA or sendB or fendA or fendB;
      if sendA or fendA then
        repeat
           Write(C^,curB);
           prevB := curB;
           curb:=NewB;
           if curb < prevB then sendB := true;
        until SendB or FendB
      else
        repeat
           Write(C^,curA);
           prevA := curA;
           cura:=NewA;
           if cura < prevA then sendA := true;
        until SendA or FendA;
      if (not fendA) and (not fendB) then ns := false;
      T := C;
      C := D;
      D := T;
      if FendA and (not FendB) then
        repeat
           Write(C^,curB);
           ns := false;
           curB := NewB;
        until FendB
      else
      if FendB and (not FendA) then
        repeat
           Write(C^,curA);
           cura:=NewA;
           ns := false;
        until FendA;
    until fendA or fendB;

      T := C;
      C := A;
      A := T;

      T := D;
      D := B;
      B := T;

      Reset(A^);
      Reset(B^);
      RewRite(C^);
      RewRite(D^);
  until (FendA or FendB) and ns;
  WriteLn('Сортировка ',Tlen,' элементов закончена !');
  GetTime(H2,M2,S2,S3);
  WriteLn('Текущее время: ',H2,' часов ',M2,' минут ',S2,' секунд');
  H1 := H2 - H1;
  if M1 > M2 then
   begin
    Dec(h1);
    M1 := M2-M1+60;
   end
  else M1 := M2-M1;
  if S1 > S2 then
   begin
    Dec(M1);
    S1 := S2-S1+60;
   end
  else S1 := S2-S1;
  WriteLn('Затрачено: ',H1,' часов ',M1,' минут ',S1,' секунд');
  WriteLn('Формируем выходной файл...');
  Assign(Ftext,'output.txt');
  Rewrite(Ftext);
  repeat
    Read(B^,curA);
    WriteLn(Ftext,curA);
  until EOF(B^);
  Close(A^);
  Close(B^);
  Close(C^);
  Close(D^);
  Close(Ftext);

  Dispose(A);
  Dispose(B);
  Dispose(C);
  Dispose(D);
END.