回 帖 发 新 帖 刷新版面

主题:《冰原探险》

[问题描述]
  给出各个冰山的位置,按照指定的规则将一个冰块推到指定的位置且步数最少。



[问题解法]
  很明显,该题必须搜索。应当采取的方法是广度。



广度的状态:
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[i] 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[i].x1 <= srcx) and (iceberg[i].x2 >= srcx) then
    if (iceberg[i].y2 + 1 < srcy) and (iceberg[i].y2 + 1 > m1) then
    begin m1 := iceberg[i].y2; p1 := i; end;
    if (iceberg[i].x1 <= srcx) and (iceberg[i].x2 >= srcx) then
    if (iceberg[i].y1 - 1 > srcy) and (iceberg[i].y1 - 1 < m2) then
    begin m2 := iceberg[i].y1; p2 := i; end;
   end;
  end
 else
  begin
   m1 := -maxint; m2 := maxint;
   for i := 1 to n + 1 do
   begin
    if (iceberg[i].y1 <= srcy) and (iceberg[i].y2 >= srcy) then
    if (iceberg[i].x2 + 1 < srcx) and (iceberg[i].x2 + 1 > m1) then
    begin m1 := iceberg[i].x2; p1 := i; end;
    if (iceberg[i].y1 <= srcy) and (iceberg[i].y2 >= srcy) then
    if (iceberg[i].x1 - 1 > srcx) and (iceberg[i].x1 - 1 < m2) then
    begin m2 := iceberg[i].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[i].x1 <= x) and (iceberg[i].x2 >= x) then
   if (iceberg[i].y2 + 1 < y) and (iceberg[i].y2 + 1 > m1) then
   begin m1 := iceberg[i].y2; p1 := i; end;
   if (iceberg[i].x1 <= x) and (iceberg[i].x2 >= x) then
   if (iceberg[i].y1 - 1 > y) and (iceberg[i].y1 - 1 < m2) then
   begin m2 := iceberg[i].y1; p2 := i; end;
  end;
 end
else
 begin
  m1 := -maxint; m2 := maxint;
  for i := 1 to n + 1 do
  begin
   if (iceberg[i].y1 <= y) and (iceberg[i].y2 >= y) then
   if (iceberg[i].x2 + 1 < x) and (iceberg[i].x2 + 1 > m1) then
   begin m1 := iceberg[i].x2; p1 := i; end;
   if (iceberg[i].y1 <= y) and (iceberg[i].y2 >= y) then
   if (iceberg[i].x1 - 1 > x) and (iceberg[i].x1 - 1 < m2) then
   begin m2 := iceberg[i].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[i].ibid, a1[i].bor, next1, next2);
   b := 5 - move[a1[i].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[i].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.

回复列表 (共1个回复)

沙发

能把指定的规则说清楚些吗?

我来回复

您尚未登录,请登录后再回复。点此登录或注册