Cod sursa(job #109875)

Utilizator Pepelea_FlaviuFlaviu Pepelea Pepelea_Flaviu Data 25 noiembrie 2007 12:52:05
Problema Pairs Scor 0
Compilator fpc Status done
Runda preONI 2008, Runda 1, Clasa a 10-a Marime 1.75 kb
var fi,fo:text;
    prim:array[1..11000]of integer;
    pr:array[1..10000]of integer;
    nr:array[1..100000]of longint;
    l:longint;
procedure Ciur_Eratostene;
var i,j:longint;
begin
     i:=3;
     pr[1]:=2;
     l:=1;
     while i<=1100 do
        begin
          if prim[i]=0 then
             begin
               inc(l);
               j:=3*i;
               pr[l]:=i;
               while j<=1100 do
                begin
                  prim[j]:=1;
                  inc(j,i);
                end;
             end;
          inc(i,2);
        end;
end;
function verif(x1,x2:longint):longint;
var a,b,aux,aux2,k:longint;
begin
     verif:=0;
     if x1>x2 then begin b:=x1; a:=x2; end
              else begin b:=x2; a:=x1; end;
     if b mod a=0 then begin verif:=1; exit; end;
     if (a and 1=0)and(b and 1=0) then begin verif:=1; exit; end;
     if (b=a+1) then begin verif:=0; exit; end;
     aux:=trunc(sqrt(a));
     for k:=1 to l do
         if aux>=pr[k] then
            begin
              if (a mod pr[k]=0) and (b mod pr[k]=0) then
                 begin verif:=1; exit; end;
              if a mod pr[k]=0 then
                 begin
                   aux2:=a div pr[k];
                   if b mod aux2=0 then begin verif:=1; exit; end;
                 end;
            end
          else
           exit;
end;
var i,n,m,j,ct:longint;
begin
     assign(fi,'pairs.in'); reset(fi);
     assign(fo,'pairs.out'); rewrite(fo);
     Ciur_Eratostene;
     readln(fi,n); ct:=0;
     for i:=1 to n do
        begin
             readln(fi,nr[i]);
             for j:=i-1 downto 1 do
                if verif(nr[i],nr[j])<>1 then inc(ct);
        end;
     writeln(fo,ct);
     close(fi);
     close(fo);
end.