Cod sursa(job #25980)

Utilizator CezarMocanCezar Mocan CezarMocan Data 4 martie 2007 17:08:50
Problema Zero 2 Scor 50
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.87 kb
const inf=100000000000000000;
var n,b,i,j,contor:longint;
    nr,min,t,ant,aux:int64;
    f,p,zero:array[0..1000]of longint;
    v:array[1..1000]of int64;

procedure descomp(n:longint);
var d,i:longint;
begin
if n mod 2=0 then
        begin
        inc(f[0]);
        f[1]:=2;
        while n mod 2=0 do
                begin
                inc(p[1]);
                n:=n div 2;
                end;
        end;
d:=3;
while (n>1) do
        begin
        while (n mod d<>0)and(d*d<=n) do
                inc(d,2);
        if d*d>n then
                begin
                inc(f[0]);
                f[f[0]]:=n;
                p[f[0]]:=1;
                exit;
                end;
        inc(f[0]);
        f[f[0]]:=d;
        while n mod d=0 do
                begin
                inc(p[f[0]]);
                n:=n div d;
                end;
        end;
end;

begin
assign(input,'zero2.in');reset(input);
assign(output,'zero2.out');rewrite(output);
for contor:=1 to 10 do
        begin
        readln(n,b);
        descomp(b);
        for i:=1 to f[0] do
                begin
                nr:=0;
                ant:=0;
                for j:=1 to n do
                        begin
                        t:=f[i];
                        aux:=j;
                        while aux mod t=0 do
                                begin
                                inc(ant);
                                aux:=aux div t;
                                end;
                        nr:=nr+ant;
                        end;
                aux:=p[i];
                v[i]:=nr div aux;
                end;
        min:=inf;
        for i:=1 to f[0] do
                if v[i]<min then
                        min:=v[i];
        writeln(min);
        f:=zero;
        p:=zero;
        end;
close(input);close(output);
end.