Авторські розв'язки задач третього туру у вищій лізі
Задача 1.
CONST Dim = 101;
VAR A:Array[1..Dim,1..Dim] of integer;
Black1,Black2,B2:Array[1..Dim] of integer;
N,M,Res:integer;
tel,shov:Array[1..Dim] of record
x,y:real;
end;
FUNCTION Dist(i,j:integer):real;
begin;
Dist:= sqr(real(tel[i].x) - shov[j].x) + sqr(real(tel[i].y) - shov[j].y);
end;
PROCEDURE ReadData;
var i,j:integer;
T,VEL:real;
begin
assign(input,'METEOR.DAT'); reset(INPUT);
read(T);
read(N);
for i:=1 to N do read(tel[i].x, tel[i].y);
readln(M);
for i:=1 to M do read(shov[i].x, shov[i].y);
read(VEL);
close(INPUT);
for i:=1 to N do
for j:=1 to M do
if Dist(i,j) <= sqr(T*VEL) then A[i,j]:=1
else A[i,j]:=0;
end;
PROCEDURE GreedyMatching;
var i,j:integer;
begin
for i:=1 to N do
for j:=1 to M do
if (A[i,j]=1) and (Black2[j]=0) then begin
Black1[i]:=j;
Black2[j]:=i;
break;
end;
end;
FUNCTION Find2(v,from:integer):boolean; forward;
FUNCTION Find1(v,from:integer):boolean;
var i:integer;
begin
Find1:=true;
for i:=1 to M do
if (A[v,i]=1) and (B2[i]=0) then if Find2(i,v) then Exit;
Find1:=false;
end;
FUNCTION Find2(v,from:integer):boolean;
begin
B2[v]:=1;
Find2:=true;
if Black2[v]=0 then begin
Black2[v]:=from;
Black1[from]:=v;
Exit;
end
else if Find1(Black2[v],v) then begin
Black2[v]:=from;
Black1[from]:=v;
Exit;
end;
Find2:=false;
end;
PROCEDURE Solve;
var i:integer;
begin
GreedyMatching;
for i:=1 to N do
if Black1[i]=0 then begin
FillChar(B2,SizeOf(B2),0);
Find1(i,0);
end;
Res:=0;
for i:=1 to N do
if Black1[i]<>0 then inc(Res);
writeln(Res);
end;
BEGIN
ReadData;
assign(OUTPUT,'METEOR.SOL'); rewrite(OUTPUT);
Solve;
close(OUTPUT);
END.
Задача 2.
{$R-,S-,N+}
CONST Dim = 3007;
TYPE TEdge = record
x,up,down:longint;
up1,down1:integer;
first:boolean;
end;
TArrInt = Array[1..16390] of integer;
TArrLong = Array[1..16390] of record
b:byte;
w:word;
end;
TPair = record
value:longint;
num:integer;
end;
VAR Edges:Array[1..2*Dim] of ^TEdge;
N,M:integer;
Interval:^TarrInt;
Len:^TArrLong;
MaxInterval:longint;
Pairs:Array[1..2*Dim] of TPair;
Totalsum:Extended;
PROCEDURE ReadData;
var LX,LY,RX,RY,i:longint;
begin
new(Interval); FillChar(Interval^,Sizeof(Interval^),0);
new(Len); FillChar(Len^,Sizeof(Len^),0);
readln(N); M:=0;
for i:=1 to N do
begin
read(LX,LY,RX,RY);
inc(M);
new(Edges[M]);
with Edges[M]^ do
begin
X:=LX; Up:=LY; Down:=RY; first:=true;
end;
inc(M);
new(Edges[M]);
with Edges[M]^ do
begin
X:=RX; Up:=LY; Down:=RY; first:=false;
end;
end
end;
{-- SORTINGS -------------------------------}
PROCEDURE SortPairs(N:longint);
var M,i,j:longint;
bool:boolean;
p:TPair;
begin
M:=N;
repeat
M:=(M+1) div 2;
for i:=M+1 to N do
begin
j:=i-M; p:=Pairs[i]; bool:=true;
while (j>=1) and bool do
begin
if Pairs[j].value>p.value then begin Pairs[j+M]:=Pairs[j]; j:=j-M end
else bool:=false
end;
Pairs[j+M]:=p;
end;
until M=1;
end;
PROCEDURE SortEdges(N:longint);
var M,i,j:longint;
bool:boolean;
p:TEdge;
begin
M:=N;
repeat
M:=(M+1) div 2;
for i:=M+1 to N do
begin
j:=i-M; p:=Edges[i]^; bool:=true;
while (j>=1) and bool do
begin
if (Edges[j]^.x > p.x) or
(Edges[j]^.x = p.x) and (Edges[j]^.first=true) and (p.first=false)
then begin Edges[j+M]^:=Edges[j]^; j:=j-M end
else bool:=false
end;
Edges[j+M]^:=p;
end;
until M=1;
end;
{ ------------ END SORTINGS ------------}
FUNCTION Value(num:longint):longint;
begin
Value:=Pairs[num].value;
end;
PROCEDURE SetLen(node:integer; value:longint);
begin
Len^[node].w:= value mod 65536;
Len^[node].b:= value div 65536;
end;
FUNCTION GetLen(node:integer):longint;
begin
GetLen:=Len^[node].b * 65536 + Len^[node].w;
end;
PROCEDURE AddInterval(l,r,LI,RI,node,weight:longint);
var c:longint;
begin
if LI < l then LI:=l;
if RI > r then RI:=r;
c:=(L+R) div 2;
if (l=LI) and (r=RI)
then begin
Interval^[node]:=Interval^[node]+weight;
if Interval^[node] > 0
then SetLen(node,Value(r)-Value(l))
else begin
if l=r-1 then SetLen(node,0)
else SetLen(node, GetLen(2*node) + GetLen(2*node+1));
end;
end
else begin
if LI<c then AddInterval(l,c,LI,RI,2*node,weight);
if RI>c then AddInterval(c,r,LI,RI,2*node+1,weight);
if Interval^[node] > 0
then SetLen(node, Value(r)-Value(l))
else SetLen(node, GetLen(2*node) + GetLen(2*node+1));
end;
end;
PROCEDURE CountTotalSquare;
var x,i:longint;
LLL:Extended;
begin
MaxInterval := M;
totalsum:=0;
AddInterval(1,MaxInterval,Edges[1]^.down1, Edges[1]^.up1, 1, 1);
x:=Edges[1]^.x;
for i:=2 to M do
begin
{ writeln('i = ',i);}
LLL:=GetLen(1);
totalsum:=totalsum + LLL*(Edges[i]^.x - x);
x:=Edges[i]^.x;
if Edges[i]^.first then AddInterval(1,MaxInterval,Edges[i]^.down1, Edges[i]^.up1, 1, 1)
else AddInterval(1,MaxInterval,Edges[i]^.down1, Edges[i]^.up1, 1, -1)
end;
end;
PROCEDURE Renumbering;
var NP,k,i:integer;
begin
NP:=0;
for i:=1 to M do
begin
if Edges[i]^.first then begin
inc(NP);
Pairs[NP].value:=Edges[i]^.down;
Pairs[NP].num:=i;
inc(NP);
Pairs[NP].value:=Edges[i]^.up;
Pairs[NP].num:=-i;
end;
end;
SortPairs(M);
for i:=1 to M do
begin
k:=abs(Pairs[i].num);
if Pairs[i].num > 0 then begin
Edges[k]^.down1:=i;
Edges[k+1]^.down1:=i;
end
else begin
Edges[k]^.up1:=i;
Edges[k+1]^.up1:=i;
end;
end;
end;
BEGIN
assign(input,'FUND.DAT'); reset(INPUT);
ReadData;
Renumbering;
SortEdges(M);
CountTotalSquare;
assign(OUTPUT,'FUND.SOL'); rewrite(OUTPUT);
writeln(TotalSum:0:3);
close(OUTPUT);
END.
Задача 3.
CONST Dim = 107;
TYPE TSet = set of byte;
VAR A:Array[1..Dim,1..Dim] of byte;
Start,Finish,Curr:Array[1..Dim] of byte;
Rows:Array[1..Dim] of TSet;
N,M:integer;
RR:Tset;
YES:boolean;
PROCEDURE ReadData;
var P,K,i,j:integer;
begin
assign(INPUT,'BOMBA.DAT'); reset(INPUT);
readln(N);
for i:=1 to N do read(Start[i]);
for i:=1 to N do Finish[i]:=0;
readln(M);
for i:=1 to M do
begin
read(P);
for j:=1 to P do begin read(k); A[i,k]:=1 end;
end;
close(INPUT);
end;
PROCEDURE Swap1(k:integer);
var i,j,t:integer;
ts:TSet;
begin
if A[k,k]=1 then exit;
for i:=k+1 to M do
if A[i,k]=1 then begin
for j:=1 to N do begin
t:=A[i,j];
A[i,j]:=A[k,j];
A[k,j]:=t;
end;
Ts:=Rows[k]; Rows[k]:=Rows[i]; Rows[i]:=Ts;
Exit;
end;
end;
PROCEDURE XorSet(s1,s2:TSet; VAR Ts:Tset);
var i:integer;
b1,b2:boolean;
begin
Ts:=[];
for i:=1 to M do
begin
b1:=i in s1;
b2:=i in s2;
if b1<>b2 then Include(Ts,i);
end;
end;
PROCEDURE XorAll(k:integer);
var ts:TSet;
i,j:integer;
b1,b2:boolean;
begin
if A[k,k]=0 then Exit;
for i:=k+1 to M do
if A[i,k]=1 then begin
for j:=k to N do A[i,j]:=A[i,j] xor A[k,j];
XorSet(Rows[i],Rows[k],Ts);
Rows[i]:=Ts;
end;
end;
PROCEDURE Solve;
var MN,i,j:integer;
Ts:TSet;
begin
for i:=1 to M do Rows[i]:=[i];
for i:=1 to M-1 do
begin
if i>N then break;
Swap1(i);
XorAll(i);
end;
for i:=1 to N do Curr[i]:=Start[i];
RR:=[];
YES:=true;
for i:=1 to N do
if Curr[i]<>Finish[i] then begin
if (i>M) or (A[i,i]<>1) then begin
YES:=false;
exit
end;
for j:=1 to N do
Curr[j]:=Curr[j] xor A[i,j];
XorSet(RR,Rows[i],Ts);
RR:=Ts;
end;
end;
PROCEDURE WriteData;
var i:integer;
begin
assign(OUTPUT,'BOMBA.SOL'); rewrite(OUTPUT);
if YES then begin
writeln('YES');
for i:=1 to M do
if i in RR then write(i,' ');
writeln;
end
else writeln('NO');
close(OUTPUT);
end;
BEGIN
ReadData;
Solve;
WriteData;
END.