path.pas

仙境传说(RO)私人服务器端源代码。第一次上传。

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.