Cod sursa(job #109642)

Utilizator al3csutzuSirbu Alexandru al3csutzu Data 25 noiembrie 2007 12:14:51
Problema Pairs Scor 0
Compilator fpc Status done
Runda preONI 2008, Runda 1, Clasele 11-12 Marime 0.84 kb
program pairs;
var a:array[1..2000] of longint;
k,n,i,j,rez,min:longint;
f,g:text;
prime:boolean;
begin
  assign(f,'pairs.in'); assign(g,'pairs.out');
  reset(f); rewrite(g);
  read(f,n);
  if n>2000 then writeln(g,n*(n-1) div 2) else
  begin
  for i:=1 to n do read(f,a[i]);
  rez:=n*(n-1) div 2;
  for k:=1 to n-1 do
  for j:=k+1 to n do
  begin
    prime:=true;
    if a[k]>a[j] then min:=a[j] else min:=a[k];
    i:=3;
    if ((a[j] mod 2=0) and (a[k] mod 2=0)) or
    ((a[j] mod 3=0) and (a[k] mod 3=0)) or
    ((a[j] mod 5=0) and (a[k] mod 5=0)) then prime:=false
    else
    while (i<=min div 2) do
    begin
      if (a[k] mod i=0) and (a[j] mod i=0) then begin prime:=false; i:=(min div 2)+1; end;
      i:=i+2;
    end;
    if not prime then rez:=rez-1;
  end;
  write(g,rez);
  end;
  close(f); close(g);
end.