mapframes.pas

N年前有个法国小组用Delphi写了一个2D网游（AD&D类型）

unit MapFrames;

{
 projet ADK-ISO (c)2002-2003 Paul TOTH <[e-mail]>

 http://www.web-synergy.net/naug-land/

}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls,EditMaps, ADKScreens, ADKMaps;

type
  TMapMode=(mmBack,mmGrid,mmInsert);
  TShowOption=(moShowBack,moShowGrid,moShowObjects);
  TShowOptions=set of TShowOption;

  TMapFrame = class(TFrame)
    PaintBox1: TPaintBox;
    procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FrameResize(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
  private
    { Private declarations }
    fEditMap:TEditMap;
    fSelectMap:array of array of boolean;
    fSelStart:TPoint;
    fSelStop :TPoint;
    fSelect  :boolean;
    fMouseB,fMouseX,fMouseY:integer;
    fDragActive:boolean;
    fScrollX:integer;
    fScrollY:integer;
    fActive:TEditImage;
    fMapMode:TMapMode;
    fOptions:TShowOptions;
    maxx:integer;
    maxy:integer;
    procedure LineSE(color,x,y,width:integer);
    procedure LineSW(color,x,y,height:integer);
    procedure DrawGrid;
    procedure WMEraseBkGnd(var msg:TMessage); message WM_ERASEBKGND;
   protected
    procedure CreateWnd; override;
    procedure DestroyWnd; override;
    procedure MapResize(Sender:TObject);
  public
    { Public declarations }
    constructor Create(AOwner:TComponent); override;
    destructor Destroy; override;
    procedure LoadFromFile(AFileName:string);
    procedure Exchange(i,j:integer);
    procedure Move(Old,NewIndex:integer);
    procedure Remove(Index:integer);
    function GetItemXY(ForegroundOnly:boolean):integer;
    function ScreenToGrid(x,y:integer):TPoint;
    function Select(Point:TPoint):boolean;
    procedure SelectAll;
    procedure InvertSelection;
    procedure UnSelectAll;
    procedure SetObstacle(Value:TObstacle);
    procedure ShowImage(Image:TEditImage);
    property EditMap:TEditMap read fEditMap;
    property ScrollX:integer read fScrollX write fScrollX;
    property ScrollY:integer read fScrollY write fScrollY;
    property Active:TEditImage read fActive;
    property Mode:TMapMode read fMapMode write fMapMode;
    property Options:TShowOptions read fOptions write fOptions;
  end;

implementation

uses ImageProperties;

{$R *.dfm}

constructor TMapFrame.Create(AOwner:TComponent);
begin
 inherited;
 fEditMap:=TEditMap.Create;
 fEditMap.OnResize:=MapResize;
 fEditMap.SetSize(10,10);
 fOptions:=[moShowBack,moShowGrid,moShowObjects];
end;

destructor TMapFrame.Destroy;
begin
 //-CloseDX;
// ADKScreen.Free;
 fEditMap.Free;
 inherited;
end;

procedure TMapFrame.CreateWnd;
begin
 inherited;
 //SetupDX(Handle);
 //ResizeDX(ClientWidth,ClientHeight);
 ADKScreen:=TADKScreenDX.Create(Handle,False);
 ADKScreen.SetSize(ClientWidth,ClientHeight,WindowDepth);
end;

procedure TMapFrame.DestroyWnd;
begin
 //CloseDX;
 FreeAndNil(ADKScreen);
 inherited;
end;

procedure TMapFrame.WMEraseBkGnd(var msg:TMessage);
begin
 msg.Result:=1;
end;

procedure TMapFrame.LoadFromFile(AFileName:string);
begin
 fSelectMap:=nil;
 EditMap.LoadFromFile(AFileName);
end;

procedure TMapFrame.MapResize(Sender:TObject);
begin
 SetLength(fSelectMap,EditMap.Width,EditMap.Height);
end;


procedure TMapFrame.PaintBox1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
 fMouseB:=ord(Button)+1;
 fMouseX:=x;
 fMouseY:=y;
 if (ssShift in Shift)and(fMapMode=mmGrid) then begin
  fSelStart:=ScreenToGrid(x,y);
  with fSelStart do if (x<0)or(y<0)or(x>=EditMap.Width)or(y>=EditMap.Height) then exit;
  fSelStop :=fSelStart;
  fSelect  :=True;
  Invalidate;
 end else
 if fMouseB=2 then begin
  SetCaptureControl(PaintBox1);
  fDragActive:=(fMapMode=mmBack)and(fActive<>nil)and(fActive.getPoint(x-fScrollX,y-fScrollY));
 end;
end;

procedure TMapFrame.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState;
  X, Y: Integer);

 procedure MoveSelection(dx,dy:integer);
 var
  i:integer;
 begin
  with EditMap do begin
   for i:=0 to ImageCount-1 do begin
    with Images[i] do begin
     if Mask<>0 then begin
      inc(Data.Position.x,dx);
      inc(Data.Position.y,dy);
     end;
    end;
   end;
   for i:=0 to ItemCount-1 do begin
    with Items[i] do begin
     if Mask<>0 then begin
      inc(Data.Position.x,dx);
      inc(Data.Position.y,dy);
     end;
    end;
   end;
  end;
 end;

begin
 if (fSelect) then begin
   fSelStop:=ScreenToGrid(x,y);
   if fSelStop.x<0 then fSelStop.x:=0 else
   if fSelStop.x>=EditMap.Width then fSelStop.x:=EditMap.Width-1;
   if fSelStop.y<0 then fSelStop.y:=0 else
   if fSelStop.y>=EditMap.Height then fSelStop.y:=EditMap.Height-1;
 end else begin
  case fMouseB of
  {
   1: if (ssCtrl in Shift)and(fMapMode=mmBack)and(fActive<>nil) then begin
     inc(fActive.Data.Position.X,x-fMouseX);
     inc(fActive.Data.Position.Y,y-fMouseY);
   end;
  }
   2: //if (fDragActive) then begin
      if not (ssAlt in Shift) then begin
       MoveSelection(x-fMouseX,y-fMouseY);
       {
       inc(fActive.Data.Position.X,x-fMouseX);
       inc(fActive.Data.Position.Y,y-fMouseY);
       }
       if (ImageEditor<>nil) and ImageEditor.Visible then ImageEditor.Image:=fActive;
      end else begin
       inc(fScrollX,x-fMouseX);
       inc(fScrollY,y-fMouseY);
      end;
   3: begin
    inc(fScrollX,x-fMouseX);
    inc(fScrollY,y-fMouseY);
   end;
   else exit;
  end;
 end;
 fMouseX:=x;
 fMouseY:=y;
 Invalidate;
end;

procedure TMapFrame.PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
 if fSelect then begin
  fSelect:=False;
  if fSelStart.x>fSelStop.x then begin
   x:=fSelStart.x; fSelStart.x:=fSelStop.x; fSelStop.x:=x;
  end;
  if fSelStart.y>fSelStop.y then begin
   y:=fSelStart.y; fSelStart.y:=fSelStop.y; fSelStop.y:=y;
  end;
  for x:=fSelStart.x to fSelStop.x do
   for y:=fSelStart.y to fSelStop.y do
    fSelectMap[x,y]:=(fMouseB=1);
  Invalidate;
 end;
 if fMouseB=2 then begin
  SetCaptureControl(nil);
  fDragActive:=False;
 end;
 fMouseB:=0;
end;

procedure TMapFrame.FrameResize(Sender: TObject);
begin
 //ResizeDX(ClientWidth,ClientHeight);
 if ADKScreen<>nil then ADKScreen.SetSize(ClientWidth,ClientHeight,WindowDepth);
end;

procedure TMapFrame.LineSE(color,x,y,width:integer);
var
 pixel:^integer;
 dx,dy:integer;
 i:integer;
begin
 if x>=maxx then exit;
// if y>=maxy then exit;
 dx:=x+48*width; if dx<0 then exit;
 dy:=y+24*width; if dy<0 then exit;
 if dy>=maxy then dec(dx,2*(dy-maxy+1));
 if dx>=maxx then dx:=maxx-1;
 if y<0 then begin
  inc(x,-2*y);
  y:=0;
 end;
 //pixel:=@dib[4*x+ADKScreen.Pitch*y];
 pixel:=ADKScreen.Pixels[x,y];
 for i:=x to dx do begin
  if i>=0 then pixel^:=color;
  inc(pixel);
  if odd(i-ScrollX) then begin
   inc(cardinal(pixel),ADKScreen.Pitch);
//   inc(y);
  end;
 end;
end;

procedure TMapFrame.LineSW(color,x,y,height:integer);
var
 pixel:^integer;
 dx,dy:integer;
 i:integer;
begin
 if x<0 then exit;
// if y>=maxy then exit;
 dx:=x-48*height; if dx>=maxx then exit;
 dy:=y+24*height; if dy<0 then exit;
 if dy>=maxy then inc(dx,2*(dy-maxy+1));
 if dx<0     then dx:=0;
 if y<0 then begin
  dec(x,-2*y);
  y:=0;
 end;
 pixel:=ADKScreen.Pixels[x,y];
 for i:=x downto dx do begin
  if i<maxx then pixel^:=color;
  dec(pixel);
  if odd(i-ScrollX) then begin
   inc(cardinal(pixel),ADKScreen.Pitch);
 //  inc(y);
  end;
 end;
end;

procedure TMapFrame.PaintBox1Paint(Sender: TObject);
begin
 if not ADKScreen.Lock then exit;
 try
  if moShowBack in fOptions then
   EditMap.DrawImages(False,PaintBox1.Width,PaintBox1.Height,fScrollX,fScrollY);

  if moShowGrid in fOptions then DrawGrid;

  if moShowObjects in fOptions then begin
   EditMap.DrawImages(True,PaintBox1.Width,PaintBox1.Height,fScrollX,fScrollY);
  end;

 finally
  //UnLockDX;
  ADKScreen.UnLock
 end;
end;

procedure TMapFrame.DrawGrid;
var
 u,v:integer;
 w,h:integer;
 x,y:integer;
 i,j:integer;
 color:integer;
begin
 maxx:=PaintBox1.Width;
 maxy:=PaintBox1.Height;

 if fMapMode=mmGrid then color:=$008080 else color:=$808080;

 u:=ScrollX+EditMap.Origin.X;
 v:=ScrollY+EditMap.Origin.Y;
 w:=EditMap.Width;
 for h:=0 to EditMap.Height do begin
  x:=u;
  y:=v; if y>=maxy then break;
  LineSE(color,x,y,w);
  dec(u,48);
  inc(v,24);
 end;

 u:=ScrollX+EditMap.Origin.X;
 v:=ScrollY+EditMap.Origin.Y;
 h:=EditMap.Height;
 for w:=0 to EditMap.Width do begin
  x:=u;
  y:=v; if y>=maxy then break;
  LineSW(color,x,y,h);
  inc(u,48);
  inc(v,24);
 end;

 if fMapMode=mmGrid then begin
  u:=ScrollX+EditMap.Origin.X;
  v:=ScrollY+EditMap.Origin.Y;
  for i:=0 to EditMap.Width-1 do begin
   for j:=0 to EditMap.Height-1 do begin
    x:=u+48*(i-j);
    y:=v+24*(i+j)-2;
    if y>maxx then break;
    if (fSelectMap[i,j]) then begin
     if (i=0)or(fSelectMap[i-1,j]=False) then LineSW($00FF00,x,y,1);
     if (j=0)or(fSelectMap[i,j-1]=False) then LineSE($00FF00,x,y,1);
     if (i=EditMap.Width-1 )or(fSelectMap[i+1,j]=False) then LineSW($00FF00,x+48,y+24,1);
     if (j=EditMap.Height-1)or(fSelectMap[i,j+1]=False) then LineSE($00FF00,x-48,y+24,1);
    end;
   end;
  end;
  if fSelect then begin
   with fSelStart do begin
    i:=u+48*(x-y);
    j:=v+24*(x+y)-2;
   end;
   x:=fSelStop.x-fSelStart.x;
   if x>=0 then
    inc(x)
   else begin
    inc(i,x*48);
    inc(j,x*24);
    x:=-x;
   end;
   y:=fSelStop.y-fSelStart.y;
   if y>=0 then
    inc(y)
   else begin
    dec(i,y*48);
    inc(j,y*24);
    y:=-y;
   end;
   LineSE($0000FF,i,j,x);
   LineSE($0000FF,i-y*48,j+y*24,x);
   LineSW($0000FF,i,j,y);
   LineSW($0000FF,i+x*48,j+x*24,y);
  end;
 end; // mmGrid
end;

procedure TMapFrame.Exchange(i,j:integer);
begin
 fEditMap.Exchange(i,j);
 Invalidate;
end;

procedure TMapFrame.Move(Old,NewIndex:integer);
begin
 fEditMap.Move(Old,NewIndex);
 Invalidate;
end;

procedure TMapFrame.Remove(Index:integer);
begin
 fEditMap.Remove(Index);
 Invalidate;
end;

function TMapFrame.GetItemXY(ForeGroundOnly:boolean):integer;
var
 x,y:integer;
begin
 x:=fMouseX-fScrollX;
 y:=fMouseY-fScrollY;
 result:=fEditMap.GetItemXY(x,y,fActive,ForeGroundOnly);
 if (result>=0)and(ifForeground in fActive.Data.Flags) then inc(result,fEditMap.ImageCount);
end;

function TMapFrame.ScreenToGrid(x,y:integer):TPoint;
var
 u,v:integer;
begin
 dec(x,EditMap.Origin.x+fScrollX);
 dec(y,EditMap.Origin.y+fScrollY);
 u:=2*y+x;
 v:=2*y-x;
 Result.x:=u div 96;
 Result.y:=v div 96;
 if (u<0) then dec(Result.x);
 if (v<0) then dec(Result.y);
end;

function TMapFrame.Select(Point:TPoint):boolean;
begin
 result:=false;
 if (Point.x<0)or(Point.y<0)or(Point.x>=EditMap.Width)or(Point.y>=EditMap.Height) then exit;
 if fSelectMap[Point.X,Point.Y] then exit;
 fSelectMap[Point.x,Point.y]:=True;
 result:=true;
end;

procedure TMapFrame.SelectAll;
var
 i,l:integer;
begin
 l:=EditMap.Height;
 for i:=0 to EditMap.Width-1 do FillChar(fSelectMap[i,0],l,ord(True));
 Invalidate;
end;

procedure TMapFrame.InvertSelection;
var
 x,y:integer;
begin
 for x:=0 to EditMap.Width-1 do
  for y:=0 to EditMap.Height-1 do
   fSelectMap[x,y]:=not fSelectMap[x,y];
 Invalidate;
end;

procedure TMapFrame.UnSelectAll;
var
 i,l:integer;
begin
 l:=EditMap.Height;
 for i:=0 to EditMap.Width-1 do FillChar(fSelectMap[i,0],l,Ord(False));
 Invalidate;
end;

procedure TMapFrame.SetObstacle(Value:TObstacle);
var
 x,y:integer;
begin
 for x:=0 to EditMap.Width-1 do
  for y:=0 to EditMap.Height-1 do
   if fSelectMap[x,y] then EditMap.Cells[x,y].Obstacle:=Value;
 Invalidate;
end;

procedure TMapFrame.ShowImage(Image:TEditImage);
var
 size:TPoint;
begin
 size:=EditMap.ImageLib.Size[Image.Data.Index];
 if Image.Data.Position.x+size.x+ScrollX>ClientWidth  then ScrollX:=ClientWidth -Image.Data.Position.x-size.x;
 if Image.Data.Position.y+size.y+ScrollY>ClientHeight then ScrollY:=ClientHeight-Image.Data.Position.y-size.y;
 if Image.Data.Position.x+ScrollX<0 then ScrollX:=-Image.data.Position.x;
 if Image.Data.Position.y+ScrollY<0 then ScrollY:=-Image.data.Position.y;
end;

end.