Cod sursa(job #139336)

Utilizator eugen.nodeaEugen Nodea eugen.nodea Data 19 februarie 2008 23:15:54
Problema Factoriale Scor 40
Compilator fpc Status done
Runda Arhiva de probleme Marime 2.37 kb
const fi='factoriale.in';
      fo='factoriale.out';
      nmax=30000;
      p:array[1..25] of byte=
                     ( 2,3,5,7,11,13,17,19,23,29,
                     31,37,41,43,47,53,59,61,67,71,
                     73,79,83,89,97 );
type
    vec=array[0..nmax] of longint;
    vect=array[0..nmax] of integer;
var f:text;
    t,i,x,N,k,j,y:longint;
    A,B,C:vect;
    Ap:vec;

Procedure mul(A:vect;var B:vect);
var k,i,j,n,m:longint;
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;

Begin
     assign(f,fi); reset(f);
     Readln(f,N,K);
     For i:=1 To N do
     begin
         Read(f,x);
         j:=0;
         repeat
               j:=j+1;
               t:=p[j];
               while x div t<>0 do
               begin
                    Ap[p[j]]:=Ap[p[j]]+(x div t);
                    t:=t*p[j];
               end;
         until p[j]>=x;
     end;
    close(f);
    B[0]:=1; B[1]:=1;
    For i:=2 to nmax 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]:=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.