Cod sursa(job #174199)

Utilizator llobyLodoaba Mihai lloby Data 8 aprilie 2008 17:15:31
Problema Pairs Scor 20
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.36 kb
Program pairs;
type vec=array[1..100000] of 0..1000000;
var a: vec;
    n: longint;
Function prim(x,y: longint): boolean;
var dif: longint;
begin
   dif:=2;
   while dif>1 do
   begin
       if x>y then
          begin
             dif:=x-y;
             x:=dif;
          end
       else
          begin
             dif:=y-x;
             y:=dif;
          end;
   end;
   if dif=0 then prim:=false
                 else prim:=true;
end;

Procedure afis;
var i,nr,j: longint;
    t: text;
begin
       nr:=0;
      for i:=1 to n-1 do
        for j:=i+1 to n do
          begin
              if (a[i]<>a[j]) and (prim(a[i],a[j])) then nr:=nr+1;
          end;
      assign(t,'pairs.out'); rewrite(t);
      write(t,nr);
      close(t);
end;
Procedure cit_fis;
var t: text;
    i,j,k: longint;
    gasit: boolean;
begin
     j:=0;
     assign(t,'pairs.in'); reset(t);
     readln(t);
     while not eof(t) do
       begin
          readln(t,k);
          gasit:=false;
          if j>0 then
           begin
                For i:=1 to j do
                  if a[i]=k then gasit:=true;
           end;
          if gasit=false then begin
                               j:=j+1;
                               a[j]:=k;
                              end;
       end;
     n:=j;
     close(t);
end;
begin
    cit_fis;
    afis;
end.