Az alábbi letöltési lehetőségek közül választhatsz: (
segítség)
Típus: text/plain
Tartalmaz szöveget
Karakterkódolás: us-ascii
Méret: 1 KB
program regiok;
const maxN = 100;
type TNum = integer;
PVaros = ^TVaros;
TVaros = object
x,y:TNum;
index:TNum;
pre:Pvaros;
function root:PVaros;
end;
TTerkep = array[1..maxN]of PVaros;
var v:TTerkep;
t,n:TNum;
function TVaros.root:PVaros;
begin
if (pre^.index=index) then root:=pre else
begin
pre:=pre^.root;
root:=pre;
end;
end;
procedure load;
var i:TNum;
begin
readln(n,t);
for i:=1 to N do
begin
new(v[i]);
v[i]^.index:=i;
v[i]^.pre:=v[i];
readln(v[i]^.x,v[i]^.y);
end;
end;
procedure gcoll;
var i:TNum;
begin
for i:=1 to N do dispose(v[i]);
end;
function d(a,b:PVaros):TNum;
begin
d:=abs(a^.x-b^.x) + abs(a^.y-b^.y)
end;
procedure main;
var i,j:TNum;
begin
for i:=1 to N-1 do
for j:=i+1 to N do
begin
if (d(v[i],v[j])<=T)and(v[j]^.root^.index <> v[i]^.root^.index) then
v[j]^.root^.pre:=v[i];
end;
end;
function printc(w:boolean):TNum;
var i,j,r:TNum;
b:boolean;
begin
r:=0;
for i:=1 to N do
begin
b:=false;
for j:=1 to N do
if v[j]^.root^.index = i then
begin
if w then write(j,' ');
b:=true;
end;
if b then
begin
inc(r);
if w then writeln;
end;
end;
printc:=r;
end;
procedure print;
begin
writeln(printc(false));
printc(true);
end;
begin
load;
main;
print;
gcoll;
end.of.program
