Cod sursa(job #183626)

Utilizator radu_voroneanuVoroneanu Radu Stefan radu_voroneanu Data 22 aprilie 2008 13:36:56
Problema Pascal Scor 80
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.28 kb
var p,nr,min:array[0..10] of longint;
    f,g:text;
    z,i,j,x,numar,n,d:longint;
begin
 assign(f,'pascal.in'); reset(f);
 assign(g,'pascal.out'); rewrite(g);
 read(f,n,d);
 nr[0]:=0; numar:=0;
 case d of
 2: begin
        p[0]:=1;
        p[1]:=2;
        min[1]:=1;
    end;
 3: begin
        p[0]:=1;
        p[1]:=3;
        min[1]:=1;
    end;
 4: begin
        p[0]:=1;
        p[1]:=2;
        min[1]:=2;
    end;
 5: begin
        p[0]:=1;
        p[1]:=5;
        min[1]:=1;
    end;
 6: begin
        p[0]:=2;
        p[1]:=2;
        p[2]:=3;
        min[1]:=1;
        min[2]:=1;
    end;
 end;
 for i:=1 to n-1 do begin
  x:=n-i+1; z:=1;
  if p[1]=2 then begin
   while x and 1=0 do begin
    nr[1]:=nr[1]+1;
    x:=x shr 1;
   end;
   z:=2;
  end;
  for j:=z to p[0] do
   while x mod p[j]=0 do begin
    x:=x div p[j];
    nr[j]:=nr[j]+1;
   end;
  x:=i;
  if p[1]=2 then begin
   z:=2;
   while x and 1=0 do begin
    nr[1]:=nr[1]-1;
    x:=x shr 1;
   end;
  end;
  for j:=z to p[0] do
   while x mod p[j]=0 do begin
    x:=x div p[j];
    nr[j]:=nr[j]-1;
   end;
  numar:=numar+1;
  for j:=1 to p[0] do
   if nr[j]<min[j] then begin
    numar:=numar-1;
    break;
   end;
 end;
 writeln(g,numar);
 close(f); close(g);
end.