dxsprite.pas

delphi中很有名的delphiX组件。传奇2客户端源代码也是用这个组件。

unit DXSprite;

interface
                                    
{$INCLUDE DelphiXcfg.inc}

uses
  Windows, SysUtils, Classes, DXClass, DXDraws, DirectX;

type

  {  ESpriteError  }

  ESpriteError = class(Exception);

  {  TSprite  }

  TSpriteEngine = class;

  TSprite = class
  private
    FEngine: TSpriteEngine;
    FParent: TSprite;
    FList: TList;
    FDeaded: Boolean;
    FDrawList: TList;
    FCollisioned: Boolean;
    FMoved: Boolean;
    FVisible: Boolean;
    FX: Double;
    FY: Double;
    FZ: Integer;
    FWidth: Integer;
    FHeight: Integer;
    procedure Add(Sprite: TSprite);
    procedure Remove(Sprite: TSprite);
    procedure AddDrawList(Sprite: TSprite);
    procedure Collision2;
    procedure Draw;
    function GetClientRect: TRect;
    function GetCount: Integer;
    function GetItem(Index: Integer): TSprite;
    function GetWorldX: Double;
    function GetWorldY: Double;
    procedure SetZ(Value: Integer);
  protected
    procedure DoCollision(Sprite: TSprite; var Done: Boolean); virtual;
    procedure DoDraw; virtual;
    procedure DoMove(MoveCount: Integer); virtual;
    function GetBoundsRect: TRect; virtual;
    function TestCollision(Sprite: TSprite): Boolean; virtual;
  public
    constructor Create(AParent: TSprite); virtual;
    destructor Destroy; override;
    procedure Clear;
    function Collision: Integer;
    procedure Dead;
    procedure Move(MoveCount: Integer);
    function GetSpriteAt(X, Y: Integer): TSprite;
    property BoundsRect: TRect read GetBoundsRect;
    property ClientRect: TRect read GetClientRect;
    property Collisioned: Boolean read FCollisioned write FCollisioned;
    property Count: Integer read GetCount;
    property Engine: TSpriteEngine read FEngine;
    property Items[Index: Integer]: TSprite read GetItem; default;
    property Moved: Boolean read FMoved write FMoved;
    property Parent: TSprite read FParent;
    property Visible: Boolean read FVisible write FVisible;
    property Width: Integer read FWidth write FWidth;
    property WorldX: Double read GetWorldX;
    property WorldY: Double read GetWorldY;
    property Height: Integer read FHeight write FHeight;
    property X: Double read FX write FX;
    property Y: Double read FY write FY;
    property Z: Integer read FZ write SetZ;
  end;

  {  TImageSprite  }

  TImageSprite = class(TSprite)
  private
    FAnimCount: Integer;
    FAnimLooped: Boolean;
    FAnimPos: Double;
    FAnimSpeed: Double;
    FAnimStart: Integer;
    FImage: TPictureCollectionItem;
    FPixelCheck: Boolean;
    FTile: Boolean;
    FTransparent: Boolean;
    function GetDrawImageIndex: Integer;
    function GetDrawRect: TRect;
  protected
    procedure DoDraw; override;
    procedure DoMove(MoveCount: Integer); override;
    function GetBoundsRect: TRect; override;
    function TestCollision(Sprite: TSprite): Boolean; override;
  public
    constructor Create(AParent: TSprite); override;
    property AnimCount: Integer read FAnimCount write FAnimCount;
    property AnimLooped: Boolean read FAnimLooped write FAnimLooped;
    property AnimPos: Double read FAnimPos write FAnimPos;
    property AnimSpeed: Double read FAnimSpeed write FAnimSpeed;
    property AnimStart: Integer read FAnimStart write FAnimStart;
    property PixelCheck: Boolean read FPixelCheck write FPixelCheck;
    property Image: TPictureCollectionItem read FImage write FImage;
    property Tile: Boolean read FTile write FTile;
  end;

  {  TImageSpriteEx  }

  TImageSpriteEx = class(TImageSprite)
  private
    FAngle: Integer;
    FAlpha: Integer;
  protected
    procedure DoDraw; override;
    function GetBoundsRect: TRect; override;
    function TestCollision(Sprite: TSprite): Boolean; override;
  public
    constructor Create(AParent: TSprite); override;
    property Angle: Integer read FAngle write FAngle;
    property Alpha: Integer read FAlpha write FAlpha;
  end;
                      
  {  TBackgroundSprite  }

  TBackgroundSprite = class(TSprite)
  private
    FImage: TPictureCollectionItem;
    FCollisionMap: Pointer;
    FMap: Pointer;
    FMapWidth: Integer;
    FMapHeight: Integer;
    FTile: Boolean;
    function GetCollisionMapItem(X, Y: Integer): Boolean;
    function GetChip(X, Y: Integer): Integer;
    procedure SetChip(X, Y: Integer; Value: Integer);
    procedure SetCollisionMapItem(X, Y: Integer; Value: Boolean);
    procedure SetMapHeight(Value: Integer);
    procedure SetMapWidth(Value: Integer);
  protected
    procedure DoDraw; override;
    function GetBoundsRect: TRect; override;
    function TestCollision(Sprite: TSprite): Boolean; override;
  public
    constructor Create(AParent: TSprite); override;
    destructor Destroy; override;
    procedure SetMapSize(AMapWidth, AMapHeight: Integer);
    property Chips[X, Y: Integer]: Integer read GetChip write SetChip;
    property CollisionMap[X, Y: Integer]: Boolean read GetCollisionMapItem write SetCollisionMapItem;
    property Image: TPictureCollectionItem read FImage write FImage;
    property MapHeight: Integer read FMapHeight write SetMapHeight;
    property MapWidth: Integer read FMapWidth write SetMapWidth;
    property Tile: Boolean read FTile write FTile;
  end;

  {  TSpriteEngine  }

  TSpriteEngine = class(TSprite)
  private
    FAllCount: Integer;
    FCollisionCount: Integer;
    FCollisionDone: Boolean;
    FCollisionRect: TRect;
    FCollisionSprite: TSprite;
    FDeadList: TList;
    FDrawCount: Integer;
    FSurface: TDirectDrawSurface;
    FSurfaceRect: TRect;
    procedure SetSurface(Value: TDirectDrawSurface);
  public
    constructor Create(AParent: TSprite); override;
    destructor Destroy; override;
    procedure Dead;
    procedure Draw;
    property AllCount: Integer read FAllCount;
    property DrawCount: Integer read FDrawCount;
    property Surface: TDirectDrawSurface read FSurface write SetSurface;
    property SurfaceRect: TRect read FSurfaceRect;
  end;

  {  EDXSpriteEngineError  }

  EDXSpriteEngineError = class(Exception);

  {  TCustomDXSpriteEngine  }

  TCustomDXSpriteEngine = class(TComponent)
  private
    FDXDraw: TCustomDXDraw;
    FEngine: TSpriteEngine;
    procedure DXDrawNotifyEvent(Sender: TCustomDXDraw; NotifyType: TDXDrawNotifyType);
    procedure SetDXDraw(Value: TCustomDXDraw);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(AOnwer: TComponent); override;
    destructor Destroy; override;
    procedure Dead;
    procedure Draw;
    procedure Move(MoveCount: Integer);
    property DXDraw: TCustomDXDraw read FDXDraw write SetDXDraw;
    property Engine: TSpriteEngine read FEngine;                
  end;

  {  TDXSpriteEngine  }

  TDXSpriteEngine = class(TCustomDXSpriteEngine)
  published
    property DXDraw;
  end;

implementation

uses DXConsts;

function Mod2(i, i2: Integer): Integer;
begin
  Result := i mod i2;
  if Result<0 then
    Result := i2+Result;
end;

function Mod2f(i: Double; i2: Integer): Double;
begin
  if i2=0 then
    Result := i
  else
  begin
    Result := i-Trunc(i/i2)*i2;
    if Result<0 then
      Result := i2+Result;
  end;
end;

{  TSprite  }

constructor TSprite.Create(AParent: TSprite);
begin
  inherited Create;
  FParent := AParent;
  if FParent<>nil then
  begin
    FParent.Add(Self);
    if FParent is TSpriteEngine then
      FEngine := TSpriteEngine(FParent)
    else
      FEngine := FParent.Engine;
    Inc(FEngine.FAllCount);
  end;

  FCollisioned := True;
  FMoved := True;
  FVisible := True;
end;

destructor TSprite.Destroy;
begin
  Clear;
  if FParent<>nil then
  begin
    Dec(FEngine.FAllCount);
    FParent.Remove(Self);
    FEngine.FDeadList.Remove(Self);
  end;
  FList.Free;
  FDrawList.Free;
  inherited Destroy;
end;

procedure TSprite.Add(Sprite: TSprite);
begin
  if FList=nil then
  begin
    FList := TList.Create;
    FDrawList := TList.Create;
  end;
  FList.Add(Sprite);
  AddDrawList(Sprite);
end;

procedure TSprite.Remove(Sprite: TSprite);
begin
  FList.Remove(Sprite);
  FDrawList.Remove(Sprite);
  if FList.Count=0 then
  begin
    FList.Free;
    FList := nil;
    FDrawList.Free;
    FDrawList := nil;
  end;
end;

procedure TSprite.AddDrawList(Sprite: TSprite);
var
  L, H, I, C: Integer;
begin
  L := 0;
  H := FDrawList.Count - 1;
  while L <= H do
  begin
    I := (L + H) div 2;
    C := TSprite(FDrawList[I]).Z-Sprite.Z;
    if C < 0 then L := I + 1 else
      H := I - 1;
  end;
  FDrawList.Insert(L, Sprite);
end;

procedure TSprite.Clear;
begin
  while Count>0 do
    Items[Count-1].Free;
end;

function TSprite.Collision: Integer;
var
  i: Integer;
begin
  Result := 0;
  if (FEngine<>nil) and (not FDeaded) and (Collisioned) then
  begin
    with FEngine do
    begin
      FCollisionCount := 0;
      FCollisionDone := False;
      FCollisionRect := Self.BoundsRect;
      FCollisionSprite := Self;

      for i:=0 to Count-1 do
        Items[i].Collision2;

      Result := FCollisionCount;
    end;
  end;
end;

procedure TSprite.Collision2;
var
  i: Integer;
begin
  if Collisioned then
  begin
    if (Self<>FEngine.FCollisionSprite) and OverlapRect(BoundsRect, FEngine.FCollisionRect) and
      FEngine.FCollisionSprite.TestCollision(Self) and TestCollision(FEngine.FCollisionSprite) then
    begin
      Inc(FEngine.FCollisionCount);
      FEngine.FCollisionSprite.DoCollision(Self, FEngine.FCollisionDone);
      if (not FEngine.FCollisionSprite.Collisioned) or (FEngine.FCollisionSprite.FDeaded) then
      begin
        FEngine.FCollisionDone := True;
      end;
    end;
    if FEngine.FCollisionDone then Exit;
    for i:=0 to Count-1 do
      Items[i].Collision2;
  end;
end;

procedure TSprite.Dead;
begin
  if (FEngine<>nil) and (not FDeaded) then
  begin
    FDeaded := True;
    FEngine.FDeadList.Add(Self);
  end;
end;

procedure TSprite.DoMove;
begin
end;

procedure TSprite.DoDraw;
begin
end;

procedure TSprite.DoCollision(Sprite: TSprite; var Done: Boolean);
begin
end;

function TSprite.TestCollision(Sprite: TSprite): Boolean;
begin
  Result := True;
end;

procedure TSprite.Move(MoveCount: Integer);
var
  i: Integer;
begin
  if FMoved then
  begin
    DoMove(MoveCount);
    for i:=0 to Count-1 do
      Items[i].Move(MoveCount);
  end;
end;

procedure TSprite.Draw;
var
  i: Integer;
begin
  if FVisible then
  begin
    if FEngine<>nil then
    begin
      if OverlapRect(FEngine.FSurfaceRect, BoundsRect) then
      begin
        DoDraw;
        Inc(FEngine.FDrawCount);
      end;
    end;

    if FDrawList<>nil then
    begin
      for i:=0 to FDrawList.Count-1 do
        TSprite(FDrawList[i]).Draw;
    end;
  end;
end;

function TSprite.GetSpriteAt(X, Y: Integer): TSprite;

  procedure Collision_GetSpriteAt(X, Y: Double; Sprite: TSprite);
  var
    i: Integer;
    X2, Y2: Double;
  begin
    if Sprite.Visible and PointInRect(Point(Round(X), Round(Y)), Bounds(Round(Sprite.X), Round(Sprite.Y), Sprite.Width, Sprite.Width)) then
    begin
      if (Result=nil) or (Sprite.Z>Result.Z) then
        Result := Sprite;
    end;

    X2 := X-Sprite.X;
    Y2 := Y-Sprite.Y;
    for i:=0 to Sprite.Count-1 do
      Collision_GetSpriteAt(X2, Y2, Sprite.Items[i]);
  end;

var
  i: Integer;
  X2, Y2: Double;
begin
  Result := nil;

  X2 := X-Self.X;
  Y2 := Y-Self.Y;
  for i:=0 to Count-1 do
    Collision_GetSpriteAt(X2, Y2, Items[i]);
end;                                    

function TSprite.GetBoundsRect: TRect;
begin
  Result := Bounds(Trunc(WorldX), Trunc(WorldY), Width, Height);
end;

function TSprite.GetClientRect: TRect;
begin
  Result := Bounds(0, 0, Width, Height);
end;

function TSprite.GetCount: Integer;
begin
  if FList<>nil then
    Result := FList.Count
  else
    Result := 0;
end;

function TSprite.GetItem(Index: Integer): TSprite;
begin
  if FList<>nil then
    Result := FList[Index]
  else
    raise ESpriteError.CreateFmt(SListIndexError, [Index]);
end;           

function TSprite.GetWorldX: Double;
begin
  if Parent<>nil then
    Result := Parent.WorldX+FX
  else
    Result := FX;
end;

function TSprite.GetWorldY: Double;
begin
  if Parent<>nil then
    Result := Parent.WorldY+FY
  else
    Result := FY;
end;

procedure TSprite.SetZ(Value: Integer);
begin
  if FZ<>Value then
  begin
    FZ := Value;
    if Parent<>nil then
    begin
      Parent.FDrawList.Remove(Self);
      Parent.AddDrawList(Self);
    end;
  end;
end;

{  TImageSprite  }

constructor TImageSprite.Create(AParent: TSprite);
begin
  inherited Create(AParent);
  FTransparent := True;
end;

function TImageSprite.GetBoundsRect: TRect;
var
  dx, dy: Integer;
begin
  dx := Trunc(WorldX);
  dy := Trunc(WorldY);
  if FTile then
  begin
    dx := Mod2(dx, FEngine.SurfaceRect.Right+Width);
    dy := Mod2(dy, FEngine.SurfaceRect.Bottom+Height);

    if dx>FEngine.SurfaceRect.Right then
      dx := (dx-FEngine.SurfaceRect.Right)-Width;

    if dy>FEngine.SurfaceRect.Bottom then
      dy := (dy-FEngine.SurfaceRect.Bottom)-Height;
  end;

  Result := Bounds(dx, dy, Width, Height);
end;

procedure TImageSprite.DoMove(MoveCount: Integer);
begin
  FAnimPos := FAnimPos + FAnimSpeed*MoveCount;