File: PathFinder.pas
title
English page Russian page
13:55:41  ¤ 

PATHFINDER.PAS

////////////////////////////////////////////////////////////////////
//                                                                //
// Алгоритм обхода препятствий:                                   //
// 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.

Generated by PasToWeb, fixed by Victor Nekrasov. Copyright 2008 ...





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-2014 Victor Nekrasov