|
////////////////////////////////////////////////////////////////////
// //
// Алгоритм обхода препятствий: //
// http://www.delphikingdom.com/asp/viewitem.asp?catalogID=166 //
// исходник взят там же //
// Доработано: Виктор Некрасов //
// //
////////////////////////////////////////////////////////////////////
{.$Define Full}
unit PathFinder;
interface
Uses Windows, Types, Math, SysUtils,
{$IfDef Full}
DataSet2, ErmTypes, Pts, GeomTypes,
{$EndIf}
Graphics;
Type
TTile = packed record
value : Double;
TerrType : byte;
End;
TTileProt = record
Status : byte;
gval : Double;
fval : Double;
Prev : TPoint;
End;
THead = packed record
Width,Height:Integer;
End;
const
ttClear = 0; // проходимая клетка - самый хорошо проходимый тип территории
ttType1 = 1; // тип территории 1 - самый плохо проходимый тип территории
ttType2 = 2; // тип территории 2
ttType3 = 3; // тип территории 3
ttType4 = 4; // тип территории 4
ttType5 = 5; // тип территории 5
ttWall = 6; // препятствие
tsUnvisited = 0; // непосещенная точка
tsPath = 1; // путь
tsBound = 2; // граничная точка
tsPassed = 3; // проверенная точка
tsStart = 4; // точка старта
tsFinish = 5; // точка финиша
Courses : array [1..8] of TPoint=((X:0;Y:-1),(X:1;Y:-1),(X:1;Y:0), (X:1;Y:1),
(X:0;Y:1), (X:-1;Y:1),(X:-1;Y:0),(X:-1;Y:-1));
NullPoint : TPoint = (X:-1;Y:-1);
NullTile:TTile = ( value:0; TerrType:ttClear );
// цвета для создания картинки SaveToImg
TerrColors : array [0..6] of TColor = (clWhite,$999999,$AAAAAA,$BBBBBB,$CCCCCC,$DDDDDD,$555555);
StatusColors : array [0..5] of TColor = (clWhite,$FF0000,$00DDDD,$00BB00,clGreen,clRed);
Type
TMap = Class
private
FMap : Array of TTile; //массив точек карты (для наружного применения)
FMapPro : Array of TTileProt;//служебный массив точек для работы алгоритма поиска
FHeight : Integer;
FWidth : Integer;
FBound : array of TPoint;// служебный массив границ
FBSize : Integer; // размер служебного массива границ
FSrc,FDst : TPoint;
FHead : THead;
function GetMap(col,row:Integer):TTile;
procedure SetMap(col,row:Integer;T:TTile);
function GetMapStatus(col,row:Integer):byte;
procedure SetMapStatus(col,row:Integer;T:byte);
Function FindMin: integer;
procedure AddToBound(Point:TPoint);
public
ErrorStr : String;
PathLength : Integer;
Time : Cardinal;
Xmin,Ymax,Step : Double;// геопризязка верхнего левого угла (0,0) и шаг
constructor Create(Height,Width:Integer);
procedure Clear; // очистка всего поля
procedure Wall; // создать стену по крайним клеткам поля
procedure Unvisit;// стереть поисковые данные - применить перед поиском!
Function GoodPoint(a:TPoint):boolean ;
Function FindPath(Src,Dst: TPoint): boolean;
// делает список точек пути, результат объект - массив точек от Dst к Src
{$IfDef Full}Function PathToLine:TPXYZ;
Function SaveToImg(const name:String):Boolean;
{$EndIf}
Function SaveToFile(const name:String):Boolean;
Function LoadFromFile(const name:String):Boolean;
property Map[col,row:Integer]:TTile read GetMap write SetMap;
property MapStatus[col,row:Integer]:byte read GetMapStatus write SetMapStatus;
End;
implementation
constructor TMap.Create(Height,Width:Integer);
Begin
inherited Create;
FHeight := Height;
FWidth := Width;
SetLength(FMap,FHeight*FWidth);
SetLength(FMapPro,FHeight*FWidth);
End;
function TMap.GetMap(col,row:Integer):TTile;
Begin
If (col<0)or(col>=FWidth)or(row<0)or(row>=FHeight) Then Result := NullTile
Else Result := FMap[row*FWidth+col];
End;
procedure TMap.SetMap(col,row:Integer;T:TTile);
Begin
If (col<0)or(col>=FWidth)or(row<0)or(row>=FHeight) Then Exit;
FMap[row*FWidth+col]:=T;
End;
function TMap.GetMapStatus(col,row:Integer):byte;
Begin
If (col<0)or(col>=FWidth)or(row<0)or(row>=FHeight) Then Result := tsUnvisited
Else Result := FMapPro[row*FWidth+col].status;
End;
procedure TMap.SetMapStatus(col,row:Integer;T:byte);
Begin
If (col<0)or(col>=FWidth)or(row<0)or(row>=FHeight) Then Exit;
FMapPro[row*FWidth+col].Status:=T;
End;
Function TMap.FindMin: integer;
var i,n: integer;
Ti,Tn : TPoint;
Begin
n:=0;
Tn := FBound[n];
For i:=0 To FBSize-1 Do Begin
Ti := FBound[i];
If FMapPro[Tn.X+Tn.Y*FWidth].fval>FMapPro[Ti.X+Ti.Y*FWidth].fval Then Begin
n:=i; Tn := FBound[n];
End;
End;
result:=n;
End;
procedure TMap.AddToBound(Point:TPoint);
Const delta = 100;
Begin
If Length(FBound)<=FBSize Then
SetLength(FBound,FBSize+delta);
FBound[FBSize]:=Point;
Inc(FBSize);
End;
procedure TMap.Clear;
Var i,j,pos:Integer;
Begin
For j:=0 to FHeight-1 do begin
pos := j*FWidth;
For i:=0 To FWidth-1 do Begin
FMap [pos+i].TerrType := ttClear;
FMap [pos+i].value := 1;
FMapPro[pos+i].Status := tsUnvisited;
End;
End;
End;
// стена по крайним клеткам поля
procedure TMap.Wall;
Var i,j:Integer;
Begin
For i:=0 To FWidth-1 do Begin
// top line
FMap[i].TerrType := ttWall;
FMap[i].value := 1;
// bottom line
FMap[(FHeight-1)*FWidth+i].TerrType := ttWall;
FMap[(FHeight-1)*FWidth+i].value := 1;
If (i=0)or(i=FWidth-1) Then
For j:=0 to FHeight-1 do begin
FMap[j*FWidth+i].TerrType := ttWall;
FMap[j*FWidth+i].value := 1;
End;
End;
End;
// отметить непосещенными все точки
procedure TMap.Unvisit;
Var i,j,pos:Integer;
Begin
For j:=0 to FHeight-1 do begin
pos := j*FWidth;
For i:=0 To FWidth-1 do Begin
FMapPro[pos+i].Status := tsUnvisited;
FMapPro[pos+i].Prev := NullPoint;
End;
End;
End;
Function EqualPoints(a,b:TPoint):boolean ;
Begin
Result:=(A.X=B.X) and (A.Y=B.Y);
End;
Function TMap.GoodPoint(a:TPoint):boolean ;
Begin
Result:=(A.X>=0)and(A.X<FWidth) and (A.Y>=0)and(A.Y<FHeight);
End;
Function Point(AX , AY : integer): TPoint;
Begin
Result.X:=AX;Result.Y:=AY;
End;
Function HEst(A,B: TPoint; dx2,dy2:Double): Double;
var dx,dy,cross : Double;
Begin
dx:= A.X - B.X;
dy:= A.Y - B.Y;
// dx2:= Src.X - Dst.X;
// dy2:= Src.Y - Dst.Y;
cross:= dx*dy2 - dx2*dy;
If( cross<0 ) Then cross:=-cross;
Result:= max(abs(dx), abs(dy))+cross*0.001;
// Result:=sqrt(sqr(A.x-B.x)+sqr(A.y-B.y));
End;
Function TMap.FindPath(Src,Dst: TPoint): boolean;
Label __Ok, __Exi;
const kk : array[0..1] of Double=(1.42,1);
var
A : TPoint;
i,j,k : Integer;
dx,dy : Double;
Tile : TTileProt;
pos : Integer;
Begin
Time := GetTickCount;
Result := False;
If not GoodPoint(Dst) Then Begin ErrorStr := 'Dest point outside map'; Goto __Exi;End;// точкa финиша
If not GoodPoint(Src) Then Begin ErrorStr := 'Src point outside map'; Goto __Exi;End;// точкa старта
If EqualPoints(Src,Dst) Then Begin ErrorStr := 'Src and Dst points are equal';Goto __Exi;End;// точки старта и финиша одна и та же
If FMap[Dst.X+Dst.Y*FWidth].TerrType <> ttClear Then Begin ErrorStr := 'Dst point not on free cell';Goto __Exi;End;
If FMap[Src.X+Src.Y*FWidth].TerrType <> ttClear Then Begin ErrorStr := 'Src point not on free cell';Goto __Exi;End;
FSrc := Src; FDst := Dst;
Unvisit;// обнулить рабочие массивы
dx:=Src.X-Dst.X;
dy:=Src.Y-Dst.Y;
FMapPro[Dst.X+Dst.Y*FWidth].Status := tsFinish;// точка финиша
// точка старта
FMapPro[Src.X+Src.Y*FWidth].Status :=tsBound;
FMapPro[Src.X+Src.Y*FWidth].gval :=0;
FMapPro[Src.X+Src.Y*FWidth].fval :=0+HEst(Src,Dst,dx,dy);
FBSize := 0;
AddToBound(Src);// добавить к границе точку старта
Result:=False;
While FBSize>0 Do Begin
k:=FindMin;
i:=FBound[k].x;
j:=FBound[k].y;
FMapPro[i+j*FWidth].Status := tsPassed;// точка пройдена
FBound[k]:=FBound[FBSize-1];// удалить из границы обработанную точку
Dec(FBSize);
For k:=1 To 8 Do Begin
A := Courses[k];
A.X:=A.X +i;
A.Y:=A.Y +j;
If (a.x>=0)and(a.x<FWidth) and (a.y>=0)and(a.Y<FHeight)and // проверка на выход за границу
(Map[A.x,A.y].TerrType<>ttWall) Then Begin
pos := A.x+A.y*FWidth;// положение в массиве (для ускорения)
Case FMapPro[pos].Status of
tsUnvisited:Begin
Tile.gval :=FMapPro[i+j*FWidth].gval+FMap[pos].value*kk[k mod 2];
Tile.fval :=Tile.gval+HEst(A,Dst,dx,dy);
Tile.Prev :=Point(i,j);
Tile.Status := tsBound;
FMapPro[pos]:=Tile;
AddToBound(A);
End;
tsFinish :Begin
FMapPro[pos].Prev := Point(i,j);
MapStatus[Src.X,Src.Y]:=tsStart;
Result:=True;ErrorStr:='Path found';
Goto __OK;
End;
End;//Case
End;//If
End;//For
End;//While
MapStatus[Src.X,Src.Y]:=tSStart;
ErrorStr := 'Map filled, no path ';
__Ok:
// обратный проход
If Result Then Begin
PathLength := 0;
A:=FMapPro[Dst.X+Dst.Y*FWidth].Prev;
MapStatus[A.x,A.y]:=tsPassed;
While (not EqualPoints(A,Src)) do begin
inc(PathLength);
if MapStatus[A.X,A.y]<>tsBound then MapStatus[A.X,A.y]:=tsPath;
If EqualPoints(a,FMapPro[A.x+A.y*FWidth].Prev) Then Begin// следующая точка равна текущей
Result := False;ErrorStr:='No Path, cycle';Break;
End;
A:=FMapPro[A.x+A.y*FWidth].Prev;
end;
End;
__Exi:
Time := GetTickCount-Time;
End;
Function TMap.SaveToFile(const name:String):Boolean;
Var f : file;
i : Integer;
Begin
Result := False;
If name='' then Exit;
AssignFile(f,name);
ReWrite(f,1);
FHead.Width := fWidth;FHead.Height:=FHeight;
BlockWrite(f,FHead,sizeOf(THead));
For i:=0 To FWidth*FHeight-1 Do Begin
BlockWrite(f,FMap[i],SizeOf(TTile));
End;
CloseFile(f);
Result := True;
End;
Function TMap.LoadFromFile(const name:String):Boolean;
Var f : file;
i : Integer;
Begin
Result := False;
If not FileExists(name) then Exit;
AssignFile(f,name);FileMode := fmOpenRead;
Reset(f,1);
BlockRead(f,FHead,sizeOf(THead));
Fwidth:=FHead.Width;FHeight := FHead.Height;
SetLength(FMap, FHeight*FWidth);
SetLength(FMapPro,FHeight*FWidth);
For i:=0 To FWidth*FHeight-1 Do Begin
BlockRead(f,FMap[i],SizeOf(TTile));
End;
CloseFile(f);
Result := True;
End;
End.
THE COPYRIGHT of THIS DOCUMENT IS THE PROPERTY OF Victor Nekrasov.
All rights reserved. No part of this documentation may be reproduced by any means в any material form
(including photocopying or storing it в any electronic form) without the consent of the Copyright Owner or under the terms of a licence and/or
confidentiality agreement issued by the Copyright Owner, Victor Nekrasov. Applications for the
copyright owners permission to reproduce any part of this documentation should be addressed to, Victor Nekrasov, vinek@list.ru
© 1998-2023 Victor Nekrasov