Авторські розв'язки задач тренувального туру у вищій лізі

Turbo Pascal:

Type Arr = Array[0..1000] of integer;

Var Mi,Ma,Sum,Sr,SrLo,SrHi,a,b,c: Arr;
    k,t: array[0..9] of integer;
    i,j,len,ost: integer;
    fi,fo: Text;

Procedure MakeMi(Var a:arr;l:integer); Var i,j,t: integer;
Begin t:=l;
      For i:=0 to 9 do For j:=1 to k[i] do Begin a[t]:=i; dec(t) End
End;

Procedure MakeMa(Var a:arr;l:integer); Var i,j,t: integer;
Begin t:=l;
      For i:=9 downto 0 do For j:=1 to k[i] do Begin a[t]:=i; dec(t) End
End;

Procedure MakeLo; Var i,j:integer;
Begin t:=k;
     For i:=len Downto 1 do if k[Sr[i]]=0 Then Break
      Else Begin dec(k[Sr[i]]); SrLo[i]:=Sr[i] End;

     While SrLo[i]=-1 do Begin For j:=Sr[i]-1 downto 0 do
      If k[j]>0 Then Begin SrLo[i]:=j; Dec(k[j]); Break End;
      If SrLo[i]=-1 Then Begin inc(i); if i<=len Then Begin inc(k[SrLo[i]]); SrLo[i]:=-1 End End;
     End;

     MakeMa(SrLo,i-1); k:=t
End;

Procedure MakeHi; Var i,j:integer;
Begin t:=k;
     For i:=len Downto 1 do if k[Sr[i]]=0 Then Break
      Else Begin dec(k[Sr[i]]); SrHi[i]:=Sr[i] End;

     While SrHi[i]=-1 do Begin For j:=Sr[i]+1 to 9 do
      If k[j]>0 Then Begin SrHi[i]:=j; Dec(k[j]); Break End;
      If SrHi[i]=-1 Then Begin inc(i); if i<=len Then Begin inc(k[SrHi[i]]); SrHi[i]:=-1 End End;
     End;

     MakeMi(SrHi,i-1); k:=t
End;

Function Check(a,b:Arr):integer; Var i: integer;
Begin Check:=0;
      For i:=len downto 0 do
       if a[i]<b[i] Then Begin check:=1; Break End
        Else if a[i]>b[i] Then Begin check:=-1; Break End
End;

Procedure Rizn(a,b:Arr); Var i: integer; 
Begin if Check(a,b)>0 Then Begin c:=a; a:=b; b:=c End;
      For i:=len downto 0 do c[i]:=a[i]-b[i];
      For i:=0 to Len do if c[i]<0 Then Begin Inc(c[i],10); Dec(C[i+1]) End;
End;

Procedure Out(a: arr); Var i: integer;
Begin For i:=len downto 1 do If a[i]<>0 Then Break;
      For i:=i downto 1 do Write(fo,a[i]); Writeln(fo);
End;

Begin
     Assign(fi,'CIPHRY.IN'); Reset(fi);
      For i:=0 to 9 do Begin Readln(fi,k[i]); inc(len,k[i]) End;
     Close(fi);

     MakeMi(Mi,len); MakeMa(Ma,len);

     For i:=1 to len do Sum[i]:=Ma[i]+Mi[i];
     For i:=1 to len-1 do
      Begin Inc(Sum[i+1],Sum[i] div 10); Sum[i]:=Sum[i] mod 10 End;

     For i:=1 to len+1 do Begin
      ost:=ost*10+sum[len+1-i];
      sr[len+1-i]:=ost div 2;
      ost:=ost mod 2
     End;

     For i:=1 to len do Begin SrLo[i]:=-1; SrHi[i]:=-1 End;
     MakeLo; MakeHi;

     Assign(fo,'CIPHRY.OUT'); ReWrite(fo);

     Out(mi); Out(ma);

     Rizn(Sr,SrLo); a:=c; Rizn(Sr,SrHi); b:=c;
     if Check(a,b)>=0 Then Out(SrLo) Else Out(SrHi);
     Close(fo)
End.

Free Pascal:

Type Arr = Array[0..1000] of integer;

Var Mi,Ma,Sum,Sr,SrLo,SrHi: Arr;
    k,t: array[0..9] of integer;
    i,j,len,ost: integer;
    fi,fo: Text;

Procedure MakeMi(Var a:arr;l:integer); Var i,j,t: integer;
Begin t:=l;
     For i:=0 to 9 do For j:=1 to k[i] do Begin a[t]:=i; dec(t) End
End;

Procedure MakeMa(Var a:arr;l:integer); Var i,j,t: integer;
Begin t:=l;
     For i:=9 downto 0 do For j:=1 to k[i] do Begin a[t]:=i; dec(t) End
End;

Procedure MakeLo; Var i,j:integer;
Begin t:=k;
      For i:=len Downto 1 do if k[Sr[i]]=0 Then Break
       Else Begin dec(k[Sr[i]]); SrLo[i]:=Sr[i] End;

      While SrLo[i]=-1 do Begin For j:=Sr[i]-1 downto 0 do
       If k[j]>0 Then Begin SrLo[i]:=j; Dec(k[j]); Break End;
       If SrLo[i]=-1 Then Begin inc(i); if i<=len Then Begin inc(k[SrLo[i]]); SrLo[i]:=-1 End End;
      End;

      MakeMa(SrLo,i-1); k:=t
End;

Procedure MakeHi; Var i,j:integer;
Begin t:=k;
     For i:=len Downto 1 do if k[Sr[i]]=0 Then Break
      Else Begin dec(k[Sr[i]]); SrHi[i]:=Sr[i] End;

     While SrHi[i]=-1 do Begin For j:=Sr[i]+1 to 9 do
      If k[j]>0 Then Begin SrHi[i]:=j; Dec(k[j]); Break End;
      If SrHi[i]=-1 Then Begin inc(i); if i<=len Then Begin inc(k[SrHi[i]]); SrHi[i]:=-1 End End;
     End;

MakeMi(SrHi,i-1); k:=t
     End;

Function Check(a,b:Arr):integer; Var i: integer;
Begin Check:=0;
      For i:=len downto 0 do
       if a[i]<b[i] Then Begin check:=1; Break End
        Else if a[i]>b[i] Then Begin check:=-1; Break End
End;

Function Rizn(a,b:Arr):Arr; Var i: integer; c: Arr;
Begin if Check(a,b)>0 Then Begin c:=a; a:=b; b:=c End;
      For i:=len downto 0 do c[i]:=a[i]-b[i];
      For i:=0 to Len do if c[i]<0 Then Begin Inc(c[i],10); Dec(C[i+1]) End;
      Rizn:=C
End;

Procedure Out(a: arr); Var i: integer;
Begin For i:=len downto 1 do If a[i]<>0 Then Break;
      For i:=i downto 1 do Write(fo,a[i]); Writeln(fo);
End;

Begin
     Assign(fi,'CIPHRY.IN'); Reset(fi);
      For i:=0 to 9 do Begin Readln(fi,k[i]); inc(len,k[i]) End;
     Close(fi);

     MakeMi(Mi,len); MakeMa(Ma,len);

     For i:=1 to len do Sum[i]:=Ma[i]+Mi[i];
     For i:=1 to len-1 do
      Begin Inc(Sum[i+1],Sum[i] div 10); Sum[i]:=Sum[i] mod 10 End;

     For i:=1 to len+1 do Begin
      ost:=ost*10+sum[len+1-i];
      sr[len+1-i]:=ost div 2;
      ost:=ost mod 2
     End;

     For i:=1 to len do Begin SrLo[i]:=-1; SrHi[i]:=-1 End;
     MakeLo; MakeHi;

     Assign(fo,'CIPHRY.OUT'); ReWrite(fo);

     Out(mi); Out(ma);

     if Check(Rizn(Sr,SrLo),Rizn(Sr,SrHi))>=0 Then Out(SrLo) Else Out(SrHi);
     Close(fo)
End.