main.pas

带加权的寻路算法演示(DELPHI源码) 关于A*寻路算法的代码在网上有很多

unit Main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, PathFind, Grids, Buttons, StdCtrls, ExtCtrls;

type
  TTerrainTypes = (ttNormal, ttSand, ttForest, ttRoad, ttObstacle);

  TCellParams = record
    TerrainType: TTerrainTypes;
    OnPath: Boolean;
  end;

  TForm1 = class(TForm)
    DrawGrid1: TDrawGrid;
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    SpeedButton3: TSpeedButton;
    SpeedButton4: TSpeedButton;
    SpeedButton5: TSpeedButton;
    SpeedButton6: TSpeedButton;
    SpeedButton7: TSpeedButton;
    Bevel1: TBevel;
    Label1: TLabel;
    Timer1: TTimer;
    Label2: TLabel;
    Label3: TLabel;
    procedure Timer1Timer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure DrawGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
    procedure SpeedButton1Click(Sender: TObject);
    procedure SetWorkMode(Sender: TObject);
    procedure DrawGrid1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure DrawGrid1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    FData: array[0..39, 0..39] of TCellParams;
    FPath: TPath;
    FPathMap: TPathMap;
    FWorkMode: Integer;
    MCell: TPoint;
    procedure DrawPathCell(X, Y: Integer; PathVisible: Boolean);
    procedure DrawPath(PathVisible: Boolean);
    procedure SetPath(P: TPath);
  public
    property Path: TPath read FPath write SetPath;
  end;

var
  Form1: TForm1;
  PathVisCount: Integer;
function MovingCost(X, Y, Direction: Integer): Integer;
implementation

{$R *.dfm}

type
  TTerrainParam = record
    CellColor: TColor;
    CellLabel: string[16];
    MoveCost: Integer;
  end;

const
  TerrainParams: array[TTerrainTypes] of TTerrainParam = (
    (CellColor: clMaroon; CellLabel: '平地'; MoveCost: 4),
    (CellColor: clOlive; CellLabel: '沙地'; MoveCost: 6),
    (CellColor: clGreen; CellLabel: '树林'; MoveCost: 10),
    (CellColor: clSilver; CellLabel: '马路'; MoveCost: 2),
    (CellColor: clBlack; CellLabel: '障碍物'; MoveCost: - 1));

function MovingCost(X, Y, Direction: Integer): Integer;
begin
  Result := TerrainParams[Form1.FData[Y, X].TerrainType].MoveCost;
  if ((Direction and 1) = 1) and (Result > 0) then   // 如果是斜方向,则COST增加
    Result := Result +(Result shr 1); //应为Result*sqt(2),此处近似为1.5
end;

//画路径单元
procedure TForm1.DrawPathCell(X, Y: Integer; PathVisible: Boolean);
var
  R: TRect;
begin
  with DrawGrid1 do
  begin
    R := CellRect(X, Y); //画路径背景
    Canvas.Brush.Color := TerrainParams[FData[Y, X].TerrainType].CellColor;
    Canvas.FillRect(R);
    if not PathVisible then
      Exit;
    InflateRect(R, -2, -2); //画路径白点
    Canvas.Pen.Color := clWhite;
    Canvas.Brush.Color := clRed;
    Canvas.Ellipse(R);
  end;
end;

procedure TForm1.DrawPath(PathVisible: Boolean);
var
  i: Integer;
begin
  if FPath <> nil then
    for i := 0 to High(FPath) do //  PathVisCount
    begin
      FData[FPath[i].Y, FPath[i].X].OnPath := PathVisible;
      DrawPathCell(FPath[i].X, FPath[i].Y, PathVisible);
    end;
end;

procedure TForm1.SetPath(P: TPath);
begin
  DrawPath(false); //清除上次路径
  FPath := P;
  DrawPath(true); //画当前路径
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  i: Integer;
  R: TRect;
begin
  for i := 0 to (ComponentCount - 1) do
    if (Components[i] is TSpeedButton) and
      (TSpeedButton(Components[i]).GroupIndex = 1) and
      (TSpeedButton(Components[i]).Tag >= 0)
      then
      with TSpeedButton(Components[i]) do
      begin
        R := Rect(2, 2, Glyph.Width - 2, Glyph.Height - 2);
        Glyph.Canvas.Brush.Color := TerrainParams[TTerrainTypes(Tag)].CellColor;
        Glyph.Canvas.FillRect(R);
        Caption := TerrainParams[TTerrainTypes(Tag)].CellLabel;
        if TerrainParams[TTerrainTypes(Tag)].MoveCost >= 0
          then
          Caption := Caption + ' (权值：' + IntToStr(TerrainParams[TTerrainTypes(Tag)].MoveCost)
          + ')';
      end;
  FillChar(FData, SizeOf(FData), 0);
  FPath := nil;
  FPathMap := nil;
  FWorkMode := -1;
end;

procedure TForm1.DrawGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
begin
  DrawPathCell(ACol, ARow, FData[ARow, ACol].OnPath);
end;

procedure TForm1.SpeedButton1Click(Sender: TObject);
var
  X, Y: Integer;
begin
  Randomize;
  for Y := 0 to 39 do
    for X := 0 to 39 do
    begin
      FData[Y, X].TerrainType := TTerrainTypes(Random(Ord(High(TTerrainTypes)) + 1));
      FData[Y, X].OnPath := false;
    end;
  FPath := nil;
  FPathMap := nil;
  DrawGrid1.Invalidate;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  INC(PathVisCount);
  if PathVisCount > High(FPath) then
    PathVisCount := 0;

end;

procedure TForm1.SetWorkMode(Sender: TObject);
begin
  FWorkMode := TSpeedButton(Sender).Tag;
  Path := nil;
  FPathMap := nil;
end;

procedure TForm1.DrawGrid1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  C, R: Integer;
begin
  DrawGrid1.MouseToCell(X, Y, C, R);
  if (MCell.X = C) and (MCell.Y = R) then
    Exit;
  MCell := Point(C, R);
  if FWorkMode in [Ord(Low(TTerrainTypes))..Ord(High(TTerrainTypes))]
    then
  begin
    if not (ssLeft in Shift) then
      Exit;
    FData[R, C].TerrainType := TTerrainTypes(FWorkMode);
    DrawPathCell(C, R, false);
  end
  else if FPathMap <> nil then
    Path := FindPathOnMap(FPathMap, C, R);
end;

procedure TForm1.DrawGrid1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  C, R: Integer;
begin
  DrawGrid1.MouseToCell(X, Y, C, R);
  if FWorkMode in [Ord(Low(TTerrainTypes))..Ord(High(TTerrainTypes))]
    then
  begin
    FData[R, C].TerrainType := TTerrainTypes(FWorkMode);
    DrawPathCell(C, R, false);
  end
  else if FPathMap <> nil
    then
    FPathMap := nil
  else
  begin
    FPathMap := MakePathMap(40, 40, C, R, MovingCost);
    Path := FindPathOnMap(FPathMap, C, R);
    MCell := Point(C, R);
  end;
end;

end.