?? path.pas
字號:
unit Path;
interface
uses
Windows, SysUtils, Common;
//==============================================================================
// 娭悢掕媊
function DirMove(tm:TMap; var xy:TPoint; Dir:byte; bb:array of byte):boolean;
function CanMove(tm:TMap; x0, y0, x1, y1:integer):boolean;
procedure AddPath2(var aa:array of rHeap; var n:byte; rh:rHeap; x1, y1, x2, y2, dx, dy, dir, dist:integer);
function SearchPath2(var path:array of byte; tm:TMap; x1, y1, x2, y2:cardinal):byte;
procedure PopHeap(var aa:array of rHeap;var n:byte);
procedure PushHeap(var d:rHeap; var aa:array of rHeap;var n:byte);
procedure UpHeap(x:byte; var aa:array of rHeap;var n:byte);
//==============================================================================
implementation
//==============================================================================
function DirMove(tm:TMap; var xy:TPoint; Dir:byte; bb:array of byte):boolean;
var
i:integer;
xy1:TPoint;
begin
Result := false;
for i := 0 to Length(bb) - 1 do begin
xy1 := xy;
case (bb[i] + Dir) mod 8 of
0: begin Inc(xy.Y); end;
1: begin Dec(xy.X);Inc(xy.Y); end;
2: begin Dec(xy.X); end;
3: begin Dec(xy.X);Dec(xy.Y); end;
4: begin Dec(xy.Y); end;
5: begin Inc(xy.X);Dec(xy.Y); end;
6: begin Inc(xy.X); end;
7: begin Inc(xy.X);Inc(xy.Y); end;
end;
if (tm.gat[xy.X][xy.Y] and 1) = 0 then begin
xy := xy1;
exit;
end;
end;
end;
//------------------------------------------------------------------------------
function CanMove(tm:TMap; x0, y0, x1, y1:integer):boolean;
var
b1 :byte;
b2 :byte;
begin
Result := false;
if (x0 - x1 < -1) or (x0 - x1 > 1) or (y0 - y1 < -1) or (y0 - y1 > 1) then exit;
if (x1 < 0) or (y1 < 0) or (x1 >= tm.Size.X) or (y1 >= tm.Size.Y) then exit;
b1 := tm.gat[x0][y0];
if (b1 and 1) = 0 then exit;
b1 := tm.gat[x1][y1];
if (b1 and 1) = 0 then exit;
if (x0 = x1) or (y0 = y1) then begin
Result := true;
exit;
end;
b1 := tm.gat[x0][y1];
b2 := tm.gat[x1][y0];
if ((b1 and 1) = 0) or ((b2 and 1) = 0) then exit;
Result := true;
end;
//------------------------------------------------------------------------------
procedure AddPath2(var aa:array of rHeap; var n:byte; rh:rHeap; x1, y1, x2, y2, dx, dy, dir, dist:integer);
var
x, y:integer;
rh1 :rHeap;
cost:word;
begin
x := rh.mx + dx;
if (x < 0) or (x > 30) then exit;
y := rh.my + dy;
if (y < 0) or (y > 30) then exit;
cost := rh.cost2 + dist + (abs(x2 - (rh.x + dx)) + abs(y2 - (rh.y + dy))) * 10;
if mm[x][y].cost <> 0 then begin
//崱傑偱偵摨偠揰偑偁偭偨側傜cost傪斾妑偟彫偝偄側傜怴偟偄path偱偦偺揰傪嵞搊榐
if mm[x][y].cost > cost then begin
rh1.x := rh.x + dx;
rh1.y := rh.y + dy;
rh1.mx := x;
rh1.my := y;
rh1.cost2 := rh.cost2 + dist;
rh1.cost1 := cost;
//rh1.dir := dir;
CopyMemory(@rh1.path, @rh.path, rh.pcnt);
rh1.pcnt := rh.pcnt + 1;
rh1.path[rh.pcnt] := dir;
mm[x][y].cost := cost;
mm[x][y].pcnt := rh1.pcnt;
CopyMemory(@mm[x][y].path, @rh1.path, rh1.pcnt);
if mm[x][y].addr <> 0 then begin
aa[mm[x][y].addr] := rh1;
UpHeap(mm[x][y].addr, aa, n);
end else begin
mm[x][y].addr := n;
PushHeap(rh1, aa, n);
end;
end;
end else begin
//摨偠揰偑側偗傟偽偦偺揰傪搊榐
rh1.x := rh.x + dx;
rh1.y := rh.y + dy;
rh1.mx := x;
rh1.my := y;
rh1.cost2 := rh.cost2 + dist;
rh1.cost1 := cost;
//rh1.dir := dir;
CopyMemory(@rh1.path, @rh.path, rh.pcnt);
rh1.pcnt := rh.pcnt + 1;
rh1.path[rh.pcnt] := dir;
mm[x][y].cost := cost;
mm[x][y].pcnt := rh1.pcnt;
CopyMemory(@mm[x][y].path, @rh1.path, rh1.pcnt);
mm[x][y].addr := n + 1;
PushHeap(rh1, aa, n);
end;
end;
//------------------------------------------------------------------------------
function SearchPath2(var path:array of byte; tm:TMap; x1, y1, x2, y2:cardinal):byte;
var
aa :array[0..255] of rHeap;
x, y:integer;
rh :rHeap;
n :byte;
//cost:word;
//str:string;
i, j:integer;
begin
ZeroMemory(@aa, sizeof(aa));
aa[1].x := x1;
aa[1].y := y1;
aa[1].mx := 15;
aa[1].my := 15;
aa[1].cost2 := 0;
aa[1].cost1 := 1;
//aa[1].dir := 0;
aa[1].pcnt := 0;
n := 1;
ZeroMemory(@mm, sizeof(mm));
mm[15][15].cost := 1;
mm[15][15].addr := 1;
while (n <> 0) and ((aa[1].x <> x2) or (aa[1].y <> y2)) do begin
rh := aa[1];
PopHeap(aa, n);
if CanMove(tm, rh.x, rh.y, rh.x+1, rh.y-1) then
AddPath2(aa, n, rh, x1, y1, x2, y2, 1, -1, 5, 14);
if CanMove(tm, rh.x, rh.y, rh.x+1, rh.y ) then
AddPath2(aa, n, rh, x1, y1, x2, y2, 1, 0, 6, 10);
if CanMove(tm, rh.x, rh.y, rh.x+1, rh.y+1) then
AddPath2(aa, n, rh, x1, y1, x2, y2, 1, 1, 7, 14);
if CanMove(tm, rh.x, rh.y, rh.x , rh.y+1) then
AddPath2(aa, n, rh, x1, y1, x2, y2, 0, 1, 0, 10);
if CanMove(tm, rh.x, rh.y, rh.x-1, rh.y+1) then
AddPath2(aa, n, rh, x1, y1, x2, y2, -1, 1, 1, 14);
if CanMove(tm, rh.x, rh.y, rh.x-1, rh.y ) then
AddPath2(aa, n, rh, x1, y1, x2, y2, -1, 0, 2, 10);
if CanMove(tm, rh.x, rh.y, rh.x-1, rh.y-1) then
AddPath2(aa, n, rh, x1, y1, x2, y2, -1, -1, 3, 14);
if CanMove(tm, rh.x, rh.y, rh.x , rh.y-1) then
AddPath2(aa, n, rh, x1, y1, x2, y2, 0, -1, 4, 10);
end;
if n = 0 then begin
Result := 0;
exit;
end;
x := aa[1].mx;
y := aa[1].my;
if mm[x][y].cost <> 0 then begin
CopyMemory(@path, @mm[x][y].path, mm[x][y].pcnt);
Result := mm[x][y].pcnt;
end else begin
Result := 0;
end;
end;
//------------------------------------------------------------------------------
// 僸乕僾偐傜嵟彫偺梫慺傪嶍彍偡傞
procedure PopHeap(var aa:array of rHeap;var n:byte);
var
i, j :cardinal;
begin
// 僸乕僾偑嬻偱側偄偙偲傪妋擣偡傞
if n < 1 then exit;
// 僸乕僾偺嵟彫偺梫慺傪嶍彍偡傞
mm[aa[1].mx][aa[1].my].addr := 0;
// 崻偐傜弶傔偰丆愡倝偑巕傪傕偭偰偄傞尷傝孞傝曉偡
i := 1;
while i <= (n div 2) do begin // 梩傪帩偮愡偼 1..n/2
// 愡倝偺巕偺偆偪丄彫偝偄曽傪倞偲偡傞
j := i * 2;
if (j+1 <= n) and (aa[j].cost1 >= aa[j+1].cost1) then Inc(j);
// 愡倝偵愡倞偺抣傪擖傟偰丆愡倞偵拲栚偡傞
aa[i] := aa[j];
mm[aa[i].mx][aa[i].my].addr := i;
i := j;
end;
// 僸乕僾偺嵟屻偺梫慺傪愡i偵堏摦偡傞
if i <> n then begin
aa[i] := aa[n];
mm[aa[i].mx][aa[i].my].addr := i;
Dec(n);
UpHeap(i, aa, n);
end else begin
Dec(n);
end;
end;
{
procedure PopHeap(var aa:array of rHeap;var n:byte);
var
i, j :cardinal;
val :cardinal;
rh :rHeap;
begin
// 僸乕僾偑嬻偱側偄偙偲傪妋擣偡傞
if n < 1 then exit;
// 僸乕僾偺嵟屻偺梫慺傪愭摢偵堏摦偡傞
mm[aa[1].mx][aa[1].my].addr := 0;
aa[1] := aa[n];
Dec(n);
// 捑傔傜傟傞梫慺偺抣傪 val 偵僙僢僩偟偰偍偔
rh := aa[1];
val := rh.cost1;
// 崻偐傜弶傔偰丆愡倝偑巕傪傕偭偰偄傞尷傝孞傝曉偡
i := 1;
while i <= (n div 2) do begin // 梩傪帩偮愡偼 1..n/2
// 愡倝偺巕偺偆偪丄彫偝偄曽傪倞偲偡傞
j := i * 2;
if (j+1 <= n) and (aa[j].cost1 >= aa[j+1].cost1) then Inc(j);
// 傕偟丆恊偑巕傛傝戝偒偔側偄偲偄偆娭學偑惉傝棫偰偽丆
// 偙傟埲忋捑傔傞昁梫偼側偄
if val <= aa[j].cost1 then break;
// 愡倝偵愡倞偺抣傪擖傟偰丆愡倞偵拲栚偡傞
aa[i] := aa[j];
mm[aa[i].mx][aa[i].my].addr := i;
i := j;
end;
//愭摢偵偁偭偨梫慺傪愡倝偵擖傟傞
aa[i] := rh;
mm[aa[i].mx][aa[i].my].addr := i;
end;
}
//------------------------------------------------------------------------------
// 僸乕僾偵梫慺傪搊榐偡傞
procedure PushHeap(var d:rHeap; var aa:array of rHeap;var n:byte);
var
i :cardinal;
val :cardinal;
rh :rHeap;
begin
Inc(n);
aa[n] := d;
// 晜偐傃忋偑傜偣傞梫慺偺抣傪 val 偵擖傟偰偍偔
rh := aa[n];
val := rh.cost1;
// 梫慺偑崻傑偱晜偐傃忋偑偭偰偄側偄丆偐偮
// 乽恊偑巕傛傝戝偒偄乿偁偄偩孞傝曉偡
i := n;
while (i > 1) and (aa[i div 2].cost1 > val) do begin
// 恊偺抣傪巕偵堏偡
aa[i] := aa[i div 2];
mm[aa[i].mx][aa[i].my].addr := i;
i := i div 2;
end;
// 嵟廔揑側棊偪拝偒愭偑寛傑偭偨
aa[i] := rh;
mm[aa[i].mx][aa[i].my].addr := i;
end;
//------------------------------------------------------------------------------
// 僸乕僾拞偺 x 斣栚偺梫慺傪昁梫側応強傑偱晜偐傃忋偑傜偣傞
procedure UpHeap(x:byte; var aa:array of rHeap;var n:byte);
var
i :cardinal;
val :cardinal;
rh :rHeap;
begin
// 晜偐傃忋偑傜偣傞梫慺偺抣傪 val 偵擖傟偰偍偔
rh := aa[x];
val := rh.cost1;
// 梫慺偑崻傑偱晜偐傃忋偑偭偰偄側偄丆偐偮
// 乽恊偑巕傛傝戝偒偄乿偁偄偩孞傝曉偡
i := x;
while (i > 1) and (aa[i div 2].cost1 > val) do begin
// 恊偺抣傪巕偵堏偡
aa[i] := aa[i div 2];
mm[aa[i].mx][aa[i].my].addr := i;
i := i div 2;
end;
// 嵟廔揑側棊偪拝偒愭偑寛傑偭偨
aa[i] := rh;
mm[aa[i].mx][aa[i].my].addr := i;
end;
//==============================================================================
end.
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -