"冰原探险"解题报告
[问题描述]
给出各个冰山的位置，按照指定的规则将一个冰块推到指定的位置且步数最少。
[问题解法]
很明显，该题必须搜索。应当采取的方法是广度。
广度的状态：
tstatus = record
ibid : word; {冰山的序号}
bor : byte; {在冰上的哪一侧，我们对冰山的上下左右4个侧面进行了编号}
end;
因为冰山没有相接的情况，所以可以不要记下具体的位置，对于同一个冰山的侧面的任何位置，朝固定方向推冰块的效果是一样的。
这样在判重的时候也十分简单，只要用这样一个数组：
already : array[1..4000, 1..4]of boolean
already[i, j]表示第i个冰山的第j个侧面是否到达过。
我们将目的地当作第n+1个冰山，这样在扩展的时候只要碰到第n+1个冰山就出解了。
[优化措施]
对冰山按两个坐标轴的方向分别排序，可以进一步减少扩展时间。事实上，不要排序速度已经很快了。
[结论]
该题是考察参赛者基本功的搜索题。
[参考程序]
{$R-,Q-}
const
filein = 'ice.in';
fileout = 'ice.out';
up = 1;
left = 2;
right = 3;
down = 4;
move : array[1..4, 1..2]of byte = ((left, right), (up, down), (up, down), (left, right));
move2 : array[1..4, 1..2]of byte = ((up, down), (left, right), (left, right), (up, down));
type
ticeberg = record
x1, y1, x2, y2 : integer;
end;
tstate = record
ibid : word;
bor : byte;
end;
var
already : array[1..4000, 1..4]of boolean;
iceberg : array[1..4001]of ticeberg;
a1, a2 : array[1..1000]of tstate;
step, n, q1, q2 : word;
srcx, srcy, tarx, tary : integer;
time : longint;
procedure initialize;
var f : text; b : boolean; i : word;
begin
assign(f, filein); reset(f);
readln(f, n);
readln(f, srcx, srcy);
readln(f, tarx, tary);
b := true;
for i := 1 to n do
with iceberg do
readln(f, x1, y1, x2, y2);
close(f);
with iceberg[n + 1] do
begin
x1 := tarx; x2 := x1;
y1 := tary; y2 := y1;
end;
end;
procedure out;
var f : text;
begin
assign(f, fileout); rewrite(f);
writeln(f, step);
close(f);
writeln((meml[$40: $6c] - time) / 18.2 : 0 : 2);
halt;
end;
procedure expandsrc(p : byte; var p1, p2 : word);
var i, j : word;
m1, m2 : integer;
begin
p1 := 0; p2 := 0;
j := 0;
if (p = up) or (p = down) then
begin
m1 := -maxint; m2 := maxint;
for i := 1 to n + 1 do
begin
if (iceberg.x1 <= srcx) and (iceberg.x2 >= srcx) then
if (iceberg.y2 + 1 < srcy) and (iceberg.y2 + 1 > m1) then
begin m1 := iceberg.y2; p1 := i; end;
if (iceberg.x1 <= srcx) and (iceberg.x2 >= srcx) then
if (iceberg.y1 - 1 > srcy) and (iceberg.y1 - 1 < m2) then
begin m2 := iceberg.y1; p2 := i; end;
end;
end
else
begin
m1 := -maxint; m2 := maxint;
for i := 1 to n + 1 do
begin
if (iceberg.y1 <= srcy) and (iceberg.y2 >= srcy) then
if (iceberg.x2 + 1 < srcx) and (iceberg.x2 + 1 > m1) then
begin m1 := iceberg.x2; p1 := i; end;
if (iceberg.y1 <= srcy) and (iceberg.y2 >= srcy) then
if (iceberg.x1 - 1 > srcx) and (iceberg.x1 - 1 < m2) then
begin m2 := iceberg.x1; p2 := i; end;
end;
end;
if (p1 = n + 1) or (p2 = n + 1) then out;
end;
procedure expand(id : word; q : byte; var p1, p2 : word);
var i : word;
x, y, m1, m2 : integer;
begin
p1 := 0; p2 := 0;
case q of
up : begin x := iceberg[id].x1; y := iceberg[id].y1 - 1; end;
down : begin x := iceberg[id].x2; y := iceberg[id].y2 + 1; end;
right : begin x := iceberg[id].x2 + 1; y := iceberg[id].y2; end;
left : begin x := iceberg[id].x1 - 1; y := iceberg[id].y1; end;
end;
if (q = left) or (q = right) then
begin
m1 := -maxint; m2 := maxint;
for i := 1 to n + 1 do
begin
if (iceberg.x1 <= x) and (iceberg.x2 >= x) then
if (iceberg.y2 + 1 < y) and (iceberg.y2 + 1 > m1) then
begin m1 := iceberg.y2; p1 := i; end;
if (iceberg.x1 <= x) and (iceberg.x2 >= x) then
if (iceberg.y1 - 1 > y) and (iceberg.y1 - 1 < m2) then
begin m2 := iceberg.y1; p2 := i; end;
end;
end
else
begin
m1 := -maxint; m2 := maxint;
for i := 1 to n + 1 do
begin
if (iceberg.y1 <= y) and (iceberg.y2 >= y) then
if (iceberg.x2 + 1 < x) and (iceberg.x2 + 1 > m1) then
begin m1 := iceberg.x2; p1 := i; end;
if (iceberg.y1 <= y) and (iceberg.y2 >= y) then
if (iceberg.x1 - 1 > x) and (iceberg.x1 - 1 < m2) then
begin m2 := iceberg.x1; p2 := i; end;
end;
end;
if (p1 = n + 1) or (p2 = n + 1) then out;
end;
procedure firstexpand;
var i, b : byte;
next1, next2 : word;
begin
step := 1;
for i := up to left do
begin
expandsrc(i, next1, next2);
b := 5 - move2[i, 1];
if next1 <> 0 then
begin
inc(q1);
a1[q1].ibid := next1;
a1[q1].bor := b;
already[next1, b] := true
end;
b := 5 - move2[i, 2];
if next2 <> 0 then
begin
inc(q1);
a1[q1].ibid := next2;
a1[q1].bor := b;
already[next2, b] := true
end
end;
end;
procedure mainexpand;
var i : word;
j, b : byte;
next1, next2 : word;
begin
repeat
inc(step);
for i := 1 to q1 do
begin
expand(a1.ibid, a1.bor, next1, next2);
b := 5 - move[a1.bor, 1];
if next1 <> 0 then
if not already[next1, b] then
begin
inc(q2);
a2[q2].ibid := next1;
a2[q2].bor := b;
already[next1, b] := true
end;
b := 5 - move[a1.bor, 2];
if next2 <> 0 then
if not already[next2, b] then
begin
inc(q2);
a2[q2].ibid := next2;
a2[q2].bor := b;
already[next2, b] := true
end
end;
if q2 = 0 then break;
a1 := a2; q1 := q2;
q2 := 0;
until false;
end;
procedure outfailed;
var f : text;
begin
assign(f, fileout); rewrite(f);
writeln(f, 0);
close(f);
end;
begin
time := meml[$40: $6c];
initialize;
firstexpand;
mainexpand;
outfailed;
end.
