Cod sursa(job #164434)

Utilizator LegolasCazacu Iulian Legolas Data 24 martie 2008 10:53:12
Problema Oz Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.3 kb
var f,g:text;
    k,l,s,r,x,y,cmmdc,n,m,i,j:longint;
    a,b,c:array[1..10000] of longint;
    ok:boolean;
procedure QuickSort( Lo, Hi: Integer);
procedure Sort(l, r: Integer);
var i, j, x, y: integer;
begin
i := l; j := r; x := a[(l+r) DIV 2];
repeat
while a[i]<x do i:=i+1;
while x<a[j] do j:=j-1;
if i<=j then begin
y:=a[i]; a[i]:=a[j]; a[j]:=y;
y:=b[i]; b[i]:=b[j]; b[j]:=y;
y:=c[i]; c[i]:=c[j]; c[j]:=y;
i:=i+1; j:=j-1;
end;
until i > j;
if l < j then Sort(l, j);
if i < r then Sort(i, r);
end;
begin
sort(lo,hi);
end;
begin
assign(f,'oz.in');reset(f);
assign(g,'oz.out');rewrite(g);
read(f,n,m);
for i:=1 to m do
read(f,a[i],b[i],c[i]);
for i:=m+1 to 2*m do begin
a[i]:=b[i-m];
b[i]:=a[i-m];
c[i]:=c[i-m];
end;
m:=2*m;
quicksort(1,m);
i:=1;
j:=1;
ok:=true;
repeat
k:=i;
x:=c[i];
if a[i+1]=j then begin y:=c[i+1]; i:=i+2; end
else begin y:=1; i:=i+1; end;
r:=x mod y;
while r>0 do begin
x:=y;
y:=r;
r:=x mod y;
end;
cmmdc:=y;
while a[i]=j do begin
x:=cmmdc;
y:=a[i];
r:=x mod y;
while r>0 do begin
x:=y;
y:=r;
r:= x mod y;
end;
cmmdc:=y;
inc(i);
end;
s:=1;
for l:=k to i-1 do
s:=c[l]*s;
s:=s div cmmdc;
if i<=m then write(g,s,' ')
else write(g,s);
inc(j);
if a[i]<>a[i-1]+1 then ok:=false;
until (ok=false) or (i>m);
writeln(g);
close(f);
close(g);
end.