Implementando A* pathfinding en Delphi

Como ya sabéis, me encantan los retos y ejercicios de geometría computacional. Pues bien, aquí os traigo una implementación en Delphi de A* pathfinding, que consiste en encontrar y dibujar la ruta más corta entre 2 puntos saltando obstáculos. Para la resolución del pathfinding utilizaremos un algoritmo A* (A star) que es un algoritmo de búsqueda sobre grafos, intentando ir de un nodo principal a uno final con el coste mínimo. Para mi aplicación utilizaré un algoritmo creado por William Cairns donde he hecho pequeñas modificaciones y mejoras para adaptarlo a mis necesidades. Éste algoritmo se utiliza mucho en los videojuegos. Si alguna vez habéis podido leer algún libro sobre videojuegos (os lo recomiendo sobre todo por las estructuras de datos, OpenGL, etc.) nos muestran la manera que tienen para resolver que un jugador del tipo Starcraft , se mueva de un sitio a otro indicado salvando todos los obstáculos.
En la siguiente imagen, sacada de "Programación de videojuegos con SDL", podemos ver un arbol con posibles caminos dentro del mapa del juego:

En la web de policyAlmanac de U.S podemos encontrar un tutorial -> A* pathfinding para principiantes. El cuál nos muestra unas imágenes muy interesantes que me sirven para mi explicación:

Si nos fijamos en la imagen inicial:

Tenemos que ir del punto verde al punto rojo con el mínimo camino posible. Pero si nos fijamos en la imagen podemos ver que tenemos 2 caminos principales posibles, para éso hay que tener en cuenta la distancia Manhattan de manera que calculamos el número total de cuadros movidos horizontalmente y verticalmente para alcanzar el cuadrado destino desde el cuadro actual, sin hacer uso de movimientos diagonales. Al aplicar los diferentes algoritmos, obtenemos el diagrama siguiente con el cálculo realizado y el camino más corto:


Aplicación Thundax A Star PathFinding:

Aquí os dejo mi aplicación, la podéis descargar desde aquí. Por ejemplo, si creamos el ejemplo anterior, obtenemos algo parecido a:

Ahora, podemos poner los puntos donde queramos y los obstáculos que queramos y buscar el camino:


El código fuente de la unidad Astar.pas lo podéis encontrar aquí:




// originally written by William Cairns - http://www.cairnsgames.co.za
// http://www.pascalgamedevelopment.com/forums/profile.php?mode=viewprofile&u=65
// Enchanchements, additional code by Jernej L.
// http://www.gtatools.com
// please note that the path returned is REVERSED.
// Modified by Jordi Coll

unit Astar;

interface

uses
windows, dialogs, sysutils;

type
AstarRec = packed record
point: Tpoint;
weight: integer;
end;

PInspectBlock = function(X, Y, Fx, Fy: integer): integer;

var
Searching, Found: Boolean;
Astack: array of AstarRec;
Source, Goal: Tpoint;
freedom: integer;

CanGo: PInspectBlock;
GRID: array of array of integer;
GridDimensions: Tpoint;
maxval: integer;
patherror: boolean;
Path: array of Tpoint;
closestpoint: AstarRec;
IsClosest: boolean;

Offsets: array[0..7] of
record
DX, DY: Integer;
Cost: Integer;
end =
((DX: 0; DY: - 1; Cost: 10), //90° neighbour cubes
(DX: - 1; DY: 0; Cost: 10),
(DX: + 1; DY: 0; Cost: 10),
(DX: 0; DY: + 1; Cost: 10),
(DX: - 1; DY: - 1; Cost: 14), //45° diagonals
(DX: + 1; DY: - 1; Cost: 14),
(DX: - 1; DY: + 1; Cost: 14),
(DX: + 1; DY: + 1; Cost: 14));

procedure FindPath(const src, dest, Gridsize: Tpoint; const diagonals, pleasefallback: boolean; const grabcallback: PInspectBlock);

implementation

procedure
InspectBlock(X, Y: Integer);
var
I: Integer;
W: Integer;
AX, AY, AW, ABV: Integer;
begin
if (x = Source.x) and (y = Source.y) then
W := 0
else
W := GRID[x, y];
for I := 0 to freedom do
begin
AX := X + Offsets[I].DX;
AY := Y + Offsets[I].DY;
if (AX = Goal.X) and (AY = Goal.Y) then
begin
Found := True;
Exit;
end;

if (AX >= 0) and
(AY >= 0) and
(AX <= GridDimensions.x - 1) and
(AY <= GridDimensions.y - 1) = false then
continue;

if (ax = Source.x) and (ay = Source.y) then
continue;
if GRID[AX, AY] <> 0 then
continue;

ABV := CanGo(AX, AY, X, Y);
AW := W + Offsets[I].Cost + ABV;

if (ABV <> -1) then
begin
if ABV = 0 then
begin
Found := false;
Searching := false;
Exit;
end;

GRID[AX, AY] := AW;
if aw > maxval then
maxval := aw;

if (ABS(Goal.X - AX) + ABS(Goal.Y - AY)) < closestpoint.weight then
begin
closestpoint.point.x := ax;
closestpoint.point.y := ay;
closestpoint.weight := (ABS(Goal.X - AX) + ABS(Goal.Y - AY));
end;

setlength(Astack, length(Astack) + 1);
with Astack[length(Astack) - 1] do
begin
point.x := ax;
point.y := ay;
weight := aw;
end;

end;
end;
end;

procedure Step;
var
I, LC, X, Y: Integer;
begin
if Found then
Exit;
if not Searching then
begin
InspectBlock(Source.X, Source.Y);
Searching := True;
end
else
begin
if high(astack) = -1 then
begin patherror := true;
exit;
end;
LC := 0;
for i := 0 to length(Astack) - 1 do
begin
if astack[i].weight < astack[LC].weight then
LC := i;
end;
X := Astack[LC].point.x;
Y := Astack[LC].point.y;
move(astack[LC + 1], astack[LC], (length(Astack) - 1 - LC) * sizeof(AstarRec));
setlength(Astack, length(Astack) - 1);
InspectBlock(X, Y);
end;
end;

procedure CalcBestPath;
var
lowest: Tpoint;
lowvalue: integer;
finished: boolean;
function findbestprev(pt: Tpoint): Tpoint;
var
i, ax, ay: integer;
begin
for I := 0 to freedom do
begin
AX := pt.X + Offsets[I].DX;
AY := pt.Y + Offsets[I].DY;
if (AX < 0) or
(AY < 0) or
(AX > GridDimensions.x - 1) or
(AY > GridDimensions.y - 1) then
continue;
if (AX = source.X) and (AY = source.Y) then
begin
finished := True;
Exit;
end;
if GRID[AX, AY] > 0 then
begin
if GRID[AX, AY] < lowvalue then
begin
lowvalue := GRID[AX, AY];
lowest.x := ax;
lowest.y := ay;
end;

end;
end;
end;
begin
if Found = false then
exit;
finished := false;
lowvalue := maxint;
lowest := Goal;
repeat
findbestprev(lowest);
if not finished then
begin
setlength(Path, length(path) + 1);
Path[length(path) - 1] := lowest;
end;
until (finished);
end;

procedure LookForPath;
begin
repeat step;
until (found = true) or (patherror = true);
end;

procedure FindPath(const src, dest, Gridsize: Tpoint; const diagonals, pleasefallback: boolean; const grabcallback: PInspectBlock);
begin
Source := src;
Goal := dest;
freedom := 3;
if diagonals then
freedom := 7;

CanGo := grabcallback;
GridDimensions := Gridsize;
Searching := false;
Found := false;
patherror := false;
closestpoint.weight := maxint;
IsClosest := false;
setlength(Astack, 0);
setlength(Path, 0);
setlength(GRID, 0, 0);
setlength(GRID, gridsize.x, gridsize.y);
LookForPath;
if (patherror = true) and (pleasefallback = true) then
begin
Goal := closestpoint.point;
Searching := false;
Found := false;
patherror := false;
closestpoint.weight := maxint;
setlength(GRID, 0, 0);
setlength(GRID, gridsize.x, gridsize.y);
setlength(Path, length(path) + 1);
Path[length(path) - 1] := closestpoint.point;
LookForPath;
CalcBestPath;
IsClosest := true;
end
else if patherror = false then
CalcBestPath;
end;

end.






Una parte de la implementación del funcionamiento y la generación del dibujo con una TStringGrid lo podéis encontrar aquí:




function blocktester(X, Y, Fx, Fy: integer): integer;
begin
result := -1;
with Form1 do
begin
if (board.Cells[X, Y] = '') or (board.Cells[X, Y] = 'A') then
result := ((ABS(finalPos.x - X) + ABS(finalPos.y - Y)) * 3);
end;
end;

procedure TForm1.SearchClick(Sender: TObject);
var
i: integer;
begin
Astar.findpath(cellPos, finalPos, point(board.colcount, board.rowcount), true, true, @blocktester);
for i := 0 to high(astar.path) do
board.Cells[astar.path[i].x, astar.path[i].y] := '·';
if astar.IsClosest then
Statusbar1.Panels[1].text := 'Close path.';
if ((high(astar.path) = -1) and (astar.Found)) then
caption := 'immediatelly path.'
else
Statusbar1.Panels[1].text := 'Direct Path';
if not astar.Found then
Statusbar1.Panels[1].text := 'There is no path !';
end;

procedure TForm1.boardDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState);
begin
with Sender as TDrawGrid do
begin
if board.cells[acol, arow] = '1' then
Canvas.Brush.Color := shape1.Brush.color
else if board.cells[acol, arow] = '2' then
Canvas.Brush.Color := shape2.Brush.color
else if board.cells[acol, arow] = '-' then
Canvas.Brush.Color := shape3.Brush.color
else if board.cells[acol, arow] = '·' then
Canvas.Brush.Color := clyellow
else if (acol = mousePos.x) and (arow = mousePos.y) then
Canvas.Brush.Color := clwhite;
Canvas.FillRect(Rect);
Canvas.TextOut(rect.left + 12, rect.top + 8, board.cells[acol, arow]);
end;
if (state = [gdSelected]) then
with TStringGrid(Sender), Canvas do
begin
Brush.Color := clwhite;
FillRect(Rect);
TextRect(Rect, Rect.Left + 2, Rect.Top + 2, Cells[aCol, aRow]);
end;
end;


  • Enlaces de interés:
PathFinding Applet 1.

PathFinding Applet 2.



Comments

  1. Hey! hey! Wowh! That's awesome man!

    ReplyDelete
  2. Yes man!, but you've to wait for the next one -> automated linked objects. That would be one like the Neural Linking but much better!

    ReplyDelete
  3. There is a big problem with this code. It is your stack (or lack of stack because you use a linear array). If you check the the biggest performance gain in A*, you will find that it is to use a Priority Queue.
    Also, why don't you follow the traditional algorithm of the OPEN (priority queue) and CLOSED list?

    ReplyDelete
    Replies
    1. Hi,

      It certainly is indeed. One of the setbacks of this code is the list which could be heavily improved by using other kind of lists like the one you suggested (priority queue). The main reason here is that in Delphi there is no official version of "Priority Queue List" and it should be implemented. I've got the same code in Java and I've got everything correctly implemented because I already got all my basic structures (hash lists, priority queue list, balanced trees, etc).

      I hope this clarifies your comment.

      Jordi

      Delete
  4. Thanks, When I saw some of the online Jump Point Search demos, I thought this must be a clear winner. I did a comparison and found something really interesting. In your code, you use all 8 neighbors. This is a mistake! In some cases, there is only 1 neighbor (and usually less than 4)! By making a smarter neighbor method, my A* algorithm is just as fast as Jump Point Search. So, there are two critical things:
    1. Priority heap for the OPEN list
    2. Neighbor routing that only returns realistic cells.

    ReplyDelete
    Replies
    1. Thanks. I might take another approach if I had to re-do it again. This simple algorithm proves the thing and I´m thinking of adding to my repository in google code as something to work on and make some improvements.
      Jordi

      Delete

Post a Comment

Popular Posts