您所在位置：主题：《丘比特的烦恼》2
蓝色梦幻
[专家分：0] 发布于 2002-11-19 17:19:00
[原题描述]
给出一些男女之间的缘分值，按一定的规则对若干对男女射箭，求被射中的男女缘分和的最大值。
[问题分析]
该题是典型的二部图匹配。
设二部图G被划分成{X, Y}，X是男子的点集，Y是女子的点集。如果对于i∈ X和j∈ Y，按规则箭可以射中i和j，则连一条边(i, j)，边的权值是i和j的缘分值。
最后，求G的最大权完全匹配。
[关于射箭规则]
设两人的坐标(x1,y1)和(x2,y2) 。
如果[img]http://www.chinaschool.org/aosai/lwjl/images/02-0221-03.gif[/img] ，意味着Cupid的箭射程不够。
下面说一下判断两个人连线段上是否有第三者。
设另一个人的坐标是(x3,y3) 。
先考虑这三个是否共线，就是考察行列式[img]http://www.chinaschool.org/aosai/lwjl/images/02-0221-05.gif[/img]是否成立。如果三个人共线再考虑(x3,y3)是否在(x1,y1)和(x2,y2)的连线段上，即考察
(i) 如果[img]http://www.chinaschool.org/aosai/lwjl/images/02-0221-08.gif[/img]是否成立；
(ii) [img]http://www.chinaschool.org/aosai/lwjl/images/02-0221-09.gif[/img]如果是否成立。
[小结]
该题很容易看出图论模型。这是考察基本功和熟练度的题目。
[参考程序]
{$R-,Q-}
const
MaxN = 29;
FileIn = 'cupid.in';
FileOut = 'cupid.out';
var
G, Flow : array[1..Maxn, 1..Maxn]of Integer;
Value, Back : array[1..Maxn]of Integer;
Sum : Word;
N : Byte;
procedure Initialize;
type
people = record
Name : string[20];
X, Y : Longint;
end;
var
Lovers : array[1..MaxN, 1..2] of People;
sex, no : array[1..2]of byte;
Names : array[1..2]of string[20];
i, j, v : byte;
code : integer;
x1, y1,
x2, y2, k : longint;
F : text;
s : string;
function Upcases(x : string) : string;
var ss : string; i : byte;
begin
ss := '';
for i := 1 to length(x) do ss := ss + upcase(x[i]);
upcases := ss;
end;
procedure GetInfo(z : byte);
var i : byte;
begin
for i := 1 to n do
if lovers[i, 1].name = names[z] then
begin
sex[z] := 1;
no[z] := i;
exit;
end;
sex[z] := 2;
for i := 1 to n do
if lovers[i, 2].name = names[z] then
begin
no[z] := i;
exit;
end;
end;
function Check : boolean;
var j, i : byte;
x3, y3 : longint;
begin
check := false;
for j := 1 to 2 do
for i := 1 to n do
if ((j = sex[1]) and (i <> no[1])) or ((j = sex[2]) and (i <> no[2])) then
begin
x3 := lovers[i, j].X;
y3 := lovers[i, j].Y;
if (Y3 - Y2) * (X1 - X2) = (Y1 - Y2) * (X3 - X2) then
if (Y1 = Y2)and(Y2 = Y3) then
if (X1 < X3)and(X3 < X2)or(X2 < X3)and(X3 < X1) then exit else begin end
else
if (Y1 < Y3)and(Y3 < Y2)or(Y2 < Y3)and(Y3 < Y1) then exit;
end;
check := true;
end;
begin
assign(f, filein); reset(f);
readln(f, k);
k := k * k;
readln(f, n);
for j := 1 to 2 do
for i := 1 to n do
begin
read(f, Lovers[i, j].X, Lovers[i, j].Y);
readln(f, s);
s := copy(s, 2, length(s));
s := Upcases(s);
Lovers[i, j].Name := s;
end;
sex[1] := 1; sex[2] := 2;
for i := 1 to n do
for j := 1 to n do
begin
x1 := lovers[i, 1].X; y1 := lovers[i, 1].Y;
x2 := lovers[j, 2].X; y2 := lovers[j, 2].Y;
no[1] := i; no[2] := j;
if (x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2) > k then
g[i, j] := 0
else
if Check then
g[i, j] := 1
else
g[i, j] := 0
end;
readln(f, s);
while s <> 'End' do
begin
i := pos(' ', s); names[1] := upcases(copy(s, 1, i - 1)); delete(s, 1, i);
i := pos(' ', s); names[2] := upcases(copy(s, 1, i - 1)); delete(s, 1, i);
val(s, v, code);
for i := 1 to 2 do GetInfo(i);
if sex[1] = 1 then
if g[no[1], no[2]] <> 0 then g[no[1], no[2]] := v else begin end
else
if g[no[2], no[1]] <> 0 then g[no[2], no[1]] := v;
readln(f, s);
end;
close(f);
end;
procedure AddPath(x : byte);
type Each = record
father : byte;
value : integer;
end;
var L1, L2 : array[1..MaxN * 2]of Each;
Tar : Each;
i, j, k : byte;
t : integer;
changed : boolean;
begin
for i := 1 to n do
begin
if Value[i] = 0 then L1[i].Value := 0 else L1[i].value := -MaxInt;
L2[i].value := -MaxInt;
end;
tar.value := -Maxint;
repeat
changed := false;
for i := 1 to n do
if L1[i].value <> -Maxint then
for j := 1 to n do
if (flow[i, j] = 0) and (G[i, j] > 0) then
if L1[i].value + G[i, j] > L2[j].value then
begin
L2[j].value := L1[i].value + G[i, j];
L2[j].father := i;
changed := true;
end;
for j := 1 to n do
if L2[j].value <> -Maxint then
begin
for i := 1 to n do
if flow[i, j] = 1 then
if L2[j].value - g[i, j] > L1[i].value then
begin
L1[i].value := L2[j].value - g[i, j];
L1[i].father := j;
changed := true;
end;
if back[j] = 0 then
if L2[j].value > tar.value then
begin
tar.value := L2[j].value;
tar.father := j;
end;
end;
until not changed;
Sum := Sum + tar.value;
i := tar.father;
back[i] := 1;
k := 2;
while (k <> 1) or (value[i] <> 0) do
begin
case k of
1 : begin j := L1[i].father; flow[i, j] := 0; end;
2 : begin j := L2[i].father; flow[j, i] := 1; end;
end;
k := 3 - k; i := j;
end;
value[i] := 1;
end;
procedure Coupling;
var F : text; i : byte;
begin
Sum := 0;
for i := 1 to n do AddPath(i);
assign(f, fileout); rewrite(f);
writeln(f, Sum);
close(f);
end;
begin
Initialize;
Coupling;
end.
给出一些男女之间的缘分值，按一定的规则对若干对男女射箭，求被射中的男女缘分和的最大值。
[问题分析]
该题是典型的二部图匹配。
设二部图G被划分成{X, Y}，X是男子的点集，Y是女子的点集。如果对于i∈ X和j∈ Y，按规则箭可以射中i和j，则连一条边(i, j)，边的权值是i和j的缘分值。
最后，求G的最大权完全匹配。
[关于射箭规则]
设两人的坐标(x1,y1)和(x2,y2) 。
如果[img]http://www.chinaschool.org/aosai/lwjl/images/02-0221-03.gif[/img] ，意味着Cupid的箭射程不够。
下面说一下判断两个人连线段上是否有第三者。
设另一个人的坐标是(x3,y3) 。
先考虑这三个是否共线，就是考察行列式[img]http://www.chinaschool.org/aosai/lwjl/images/02-0221-05.gif[/img]是否成立。如果三个人共线再考虑(x3,y3)是否在(x1,y1)和(x2,y2)的连线段上，即考察
(i) 如果[img]http://www.chinaschool.org/aosai/lwjl/images/02-0221-08.gif[/img]是否成立；
(ii) [img]http://www.chinaschool.org/aosai/lwjl/images/02-0221-09.gif[/img]如果是否成立。
[小结]
该题很容易看出图论模型。这是考察基本功和熟练度的题目。
[参考程序]
{$R-,Q-}
const
MaxN = 29;
FileIn = 'cupid.in';
FileOut = 'cupid.out';
var
G, Flow : array[1..Maxn, 1..Maxn]of Integer;
Value, Back : array[1..Maxn]of Integer;
Sum : Word;
N : Byte;
procedure Initialize;
type
people = record
Name : string[20];
X, Y : Longint;
end;
var
Lovers : array[1..MaxN, 1..2] of People;
sex, no : array[1..2]of byte;
Names : array[1..2]of string[20];
i, j, v : byte;
code : integer;
x1, y1,
x2, y2, k : longint;
F : text;
s : string;
function Upcases(x : string) : string;
var ss : string; i : byte;
begin
ss := '';
for i := 1 to length(x) do ss := ss + upcase(x[i]);
upcases := ss;
end;
procedure GetInfo(z : byte);
var i : byte;
begin
for i := 1 to n do
if lovers[i, 1].name = names[z] then
begin
sex[z] := 1;
no[z] := i;
exit;
end;
sex[z] := 2;
for i := 1 to n do
if lovers[i, 2].name = names[z] then
begin
no[z] := i;
exit;
end;
end;
function Check : boolean;
var j, i : byte;
x3, y3 : longint;
begin
check := false;
for j := 1 to 2 do
for i := 1 to n do
if ((j = sex[1]) and (i <> no[1])) or ((j = sex[2]) and (i <> no[2])) then
begin
x3 := lovers[i, j].X;
y3 := lovers[i, j].Y;
if (Y3 - Y2) * (X1 - X2) = (Y1 - Y2) * (X3 - X2) then
if (Y1 = Y2)and(Y2 = Y3) then
if (X1 < X3)and(X3 < X2)or(X2 < X3)and(X3 < X1) then exit else begin end
else
if (Y1 < Y3)and(Y3 < Y2)or(Y2 < Y3)and(Y3 < Y1) then exit;
end;
check := true;
end;
begin
assign(f, filein); reset(f);
readln(f, k);
k := k * k;
readln(f, n);
for j := 1 to 2 do
for i := 1 to n do
begin
read(f, Lovers[i, j].X, Lovers[i, j].Y);
readln(f, s);
s := copy(s, 2, length(s));
s := Upcases(s);
Lovers[i, j].Name := s;
end;
sex[1] := 1; sex[2] := 2;
for i := 1 to n do
for j := 1 to n do
begin
x1 := lovers[i, 1].X; y1 := lovers[i, 1].Y;
x2 := lovers[j, 2].X; y2 := lovers[j, 2].Y;
no[1] := i; no[2] := j;
if (x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2) > k then
g[i, j] := 0
else
if Check then
g[i, j] := 1
else
g[i, j] := 0
end;
readln(f, s);
while s <> 'End' do
begin
i := pos(' ', s); names[1] := upcases(copy(s, 1, i - 1)); delete(s, 1, i);
i := pos(' ', s); names[2] := upcases(copy(s, 1, i - 1)); delete(s, 1, i);
val(s, v, code);
for i := 1 to 2 do GetInfo(i);
if sex[1] = 1 then
if g[no[1], no[2]] <> 0 then g[no[1], no[2]] := v else begin end
else
if g[no[2], no[1]] <> 0 then g[no[2], no[1]] := v;
readln(f, s);
end;
close(f);
end;
procedure AddPath(x : byte);
type Each = record
father : byte;
value : integer;
end;
var L1, L2 : array[1..MaxN * 2]of Each;
Tar : Each;
i, j, k : byte;
t : integer;
changed : boolean;
begin
for i := 1 to n do
begin
if Value[i] = 0 then L1[i].Value := 0 else L1[i].value := -MaxInt;
L2[i].value := -MaxInt;
end;
tar.value := -Maxint;
repeat
changed := false;
for i := 1 to n do
if L1[i].value <> -Maxint then
for j := 1 to n do
if (flow[i, j] = 0) and (G[i, j] > 0) then
if L1[i].value + G[i, j] > L2[j].value then
begin
L2[j].value := L1[i].value + G[i, j];
L2[j].father := i;
changed := true;
end;
for j := 1 to n do
if L2[j].value <> -Maxint then
begin
for i := 1 to n do
if flow[i, j] = 1 then
if L2[j].value - g[i, j] > L1[i].value then
begin
L1[i].value := L2[j].value - g[i, j];
L1[i].father := j;
changed := true;
end;
if back[j] = 0 then
if L2[j].value > tar.value then
begin
tar.value := L2[j].value;
tar.father := j;
end;
end;
until not changed;
Sum := Sum + tar.value;
i := tar.father;
back[i] := 1;
k := 2;
while (k <> 1) or (value[i] <> 0) do
begin
case k of
1 : begin j := L1[i].father; flow[i, j] := 0; end;
2 : begin j := L2[i].father; flow[j, i] := 1; end;
end;
k := 3 - k; i := j;
end;
value[i] := 1;
end;
procedure Coupling;
var F : text; i : byte;
begin
Sum := 0;
for i := 1 to n do AddPath(i);
assign(f, fileout); rewrite(f);
writeln(f, Sum);
close(f);
end;
begin
Initialize;
Coupling;
end.