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.