Cod sursa(job #138710)

Utilizator eugen.nodeaEugen Nodea eugen.nodea Data 19 februarie 2008 00:47:34
Problema Factoriale Scor 40
Compilator fpc Status done
Runda Arhiva de probleme Marime 2.35 kb
const fi='factoriale.in';
      fo='factoriale.out';
type
    vec=array[2..101] of word;
    vect=array[0..10000] of integer;
var f:text;
    i,x,N,k,j,y:integer;
    A,B,C:vect;
    Ap:vec;

Procedure mul(A:vect;var B:vect);
var k,i,j,n,m:integer;
begin
      m:=B[0]; n:=A[0];
      For i:=0 to m+n do
          C[i]:=0;
      k:=0;
      For j:=m downto 1 do
      begin
          for i:=n downto 1 do
              C[n-i+1+k]:=C[n-i+1+k]+A[i]*B[j];
          k:=k+1;
      end;
      For i:=1 to m+n-1 do
          if C[i]>=10 then begin
                                C[i+1]:=C[i+1]+C[i] Div 10;
                                C[i]:=C[i] Mod 10;
                     end;
       if C[n+m]<>0 then C[0]:=n+m
                    else C[0]:=n+m-1;
      For i:=C[0] downto 1 do
          B[C[0]-i+1]:=C[i];
      B[0]:=C[0];
end;

Procedure desc(x:byte;var A:vec);
var e,d:byte;
begin
         d:=2;
         repeat
              e:=0;
              while x Mod d=0 do
              begin
                   e:=e+1;
                   x:=x Div d;
              end;
              if e>0 then A[d]:=A[d]+e;
              d:=d+1;
         until x=1;
end;
Begin
     assign(f,fi); reset(f);
     Readln(f,N,K);
     For i:=1 To N do
     begin
         Read(f,x);
         for j:=2 to x do
             desc(j,Ap);
     end;
    close(f);
    B[0]:=1; B[1]:=1;
     For i:=1 to 101 do
         if Ap[i]>0 then
                    if Ap[i] Mod k<>0 then
                    begin
                          x:=1;
                          For j:=1 to k-(Ap[i] Mod k) do
                              x:=x*i;
                          y:=x; j:=0;
                          while y>0 do
                          begin
                               j:=j+1;
                               y:=y Div 10;
                          end;
                          { A[0]:=Trunc(Ln(x)/Ln(10)+1);}
                          A[0]:=j;
                          while x>0 do
                          begin
                               A[j]:=x Mod 10;
                               j:=j-1;
                               x:=x Div 10;
                          end;
                          mul(A,B);
                    end;
     assign(f,fo);rewrite(f);
     for i:=1 to B[0] do
         write(f,B[i]);
     close(f);
End.