grafixdx.pas

传奇源代码的delphi版本

unit GrafixDX;

{ GrafixDX v0.1a   Started 19.March.2000

  Only 16Bit mode fully supported for now.  Other modes will be added when they're
  written ;o]

  This lib is basically an extension to delphix.  Various effects where
  delphix lacks or is just too slow.  I would like for this lib to be
  continually added to ;-]

  This unit is the merging of my other units.. FontPrintDX, PixelsDX, etc..
  which I started in 1999 with a whole host of new bits.

  There is going to be 3 main people working on this lib... LifePower, Turbo
  and of course, myself - Entity.  Thanks u guyz.. this is gonna make delphix
  the ultimate for game coding :-]

  But we do urge anyone to contribute their 'cool' bits of code/ideas ;-]
  Also any bug fixes or optimizations would be most welcome :-D
  Please send any new versions to :

   NICK           EMAIL                         ICQ #

   Entity         [e-mail]             42406817
   LifePower      
   Turbo

  This way we can keep track so there isn't multiple versions :o]


[ UPDATES ]

  25.Mar.2000     Copperbar -- now 4x faster than line() !!!!!  :oD



[ IT'D BE NICE IF IT HAD... ]
     These are just things I can think of for now, and I will implement when
     I have time/patience or maybe even better u WILL ;-]

  GFX FX
   Fast AlphaBlending  - kinda essential for a game, depends on the game really
   2D Lighting         - very useful for lighting on tiles - prolly be too slow though?!?!
   AntiAliased stuff   - looks cool
   Wu Pixels/Lines     - looks even better than AA
   Bump Mapping        - very cool effect
   Tunnel              - the infamous tunnel effect
   Copper bars         - from the glorious C64/Amiga dayz

  GAME STUFF
   HiScore Table - definitely useful for games
   Line Of Sight - for dungeon games
   Simple Pathfinding - must be simple to be useful (I'm currently researching this)

  COLLISION
   Sector testing - tests if object is within a certain sector
   Bounding box   - checks if bounding boxes of objects intersect
   Point in Box/Line/Circle/Triangle/Etc - tests if a point is inside a shape

  FONT STUFF
   Proper Sinus Scroller where fonts 'rotate' as it moves through the Sinus ;-]

  MISC STUFF
   Menu capabilities          - useful allrounder
   Windowing     - maybe using skins
   Buttons stuff - well...kinda essential for windowing ;-]


   

[ THE FEATURES LIST ]

 ((Most recent first))

 NOTE: A '*' next to the Proc name denotes an update - not an addition

*** TGrafixSurface ***

   PROC NAME              TYPE        AUTHOR        DATE ADDED

   VLine                  GFX         Entity        26.Mar.2000
   RGBToBGR               UTIL        Entity        24.Mar.2000
   CopperBar              GFX         Entity        23.Mar.2000
   FlipX                  FX          Entity        23.Mar.2000
   FlipY                  FX          Entity        23.Mar.2000
   PointInCircle          COLLISION   Entity        22.Mar.2000
   GetRGB                 GFX         Entity        21.Mar.2000
   LinePolar              GFX         Entity        21.Mar.2000
   LoadFromJpeg           UTIL        Entity        20.Mar.2000
   CopyFromSurface        UTIL        Entity        20.Mar.2000
   DrawToDXDraw           UTIL        Entity        20.Mar.2000
   SetPixel               GFX         Entity        20.Mar.2000
   GetPixel               GFX         Entity        20.Mar.2000
   Line                   GFX         Entity        20.Mar.2000

*** TBmpFont ***

   PROC NAME              TYPE        AUTHOR        DATE ADDED

   TextOut                GENERAL     Entity        22.Mar.2000
   PrintChar              GENERAL     Entity        22.Mar.2000



[ DESCRIPTIONS OF THE PROCS ]

    ** UTILITY ROUTINES
    procedure LoadFromJpeg(Filename: string; ResizeFromFile: boolean);
     Load a Jpeg to the surface

    procedure CopyFromSurface(var SrcSurface: TDirectDrawSurface);
     Copy from source surface

    procedure DrawToDXDraw(xp, yp: integer; aTransparent: boolean); virtual;
     Draw the surface to DXDraw surface

    ** PIXEL FORMAT ROUTINES
    function RGBToBGR(Color: cardinal): cardinal;
     Converts Color in RGB format to Color in BGR format
     Returns Color in BGR format

    procedure GetRGB(Color: cardinal; var R, G, B: Byte);
     Returns the RGB components of a Color

    ** GFX ROUTINES
    function Lock: Boolean;
     Lock the surface ready for writing
     Returns true if successful

    procedure Unlock;
     Unlock the surface

    procedure PutPixel(x, y: Integer; Color: cardinal); virtual;
     Writes a pixel to the surface

    function GetPixel(x, y: Integer) : cardinal; virtual;
     Returns the color stored at x,y on the surface

    procedure Line(X1, Y1, X2, Y2: Integer; Color: cardinal); virtual;
     Draws a normal line

    procedure LinePolar(x, y: integer; angle, length: extended; Color: cardinal); virtual;
     Draws a line according to position, angle and length

    procedure CopperBar(y, cbHeight: integer; TopColor, MiddleColor, BottomColor: cardinal); virtual;
     Draws a copperbar - infamous from the C64/Amiga dayz :oD

    ** COLLISION ROUTINES
    function PointInCircle(xp, yp: integer; xCircle, yCircle, Radius: extended): boolean;
     Tests if a point(xp,yp) is inside a circle(xCircle, yCircle, Radius)

    ** FX ROUTINES
    procedure FlipX; virtual;
     Flip the surface horizontally

    procedure FlipY; virtual;
     Flip the surface vertically


}


interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, JPeg,
  DXClass, DXDraws,
{$IfDef StandardDX}
  DirectDraw;
{$Else}
  DirectX;
{$EndIf}

type
  TBitDepth = (bd8, bd15, bd16, bd24, bd32); // The bitdepths

  TPixelProc = procedure (x, y: Integer; Color: cardinal) of object;


  TBmpFont = class
  private
    FDXDraw: TDXDraw;
    FSurface: TDirectDrawSurface;
    FImageList: TDXImageList;
    FWidth,
    FHeight: integer;
    FNameSet,
    FNameSet2: string;
    FScale:     extended; // The scaling for the fonts
    FAspect:    extended; // Aspect ratio of surface
    procedure SetDrawSurface(aSurface: TDirectDrawsurface);
  public
    constructor Create(DestSurface: TDirectDrawSurface);
    destructor Destroy;
    procedure Init(aDXDraw: TDXDraw; aImageList: TDXImageList;
                   aNameSet, aNameSet2: string);
    // The writing routines
    procedure Textout(xp, yp: integer; mess: string; xCentred: boolean);
    procedure PrintChar(xp, yp: integer; aChar: char);
    // Time savers
    property FontName: string read FNameSet write FNameSet;
    property Surface: TDirectDrawSurface read FSurface write SetDrawSurface;
  end;


  TGrafixSurface = class(TDirectDrawSurface)
  private
    FWidth,
    FHeight:    integer;
    FDXDraw:    TDXDraw;
    FImageList: TDXImageList;
    FSurface:   TDirectDrawSurface;
//    FSurface: TGrafixSurface;
    FPixelProc: TPixelProc;
    FSurfaceDesc: TDDSurfaceDesc2;
    FBitDepth:  TBitDepth;
    FRect:      TRect;
    FAspect:    extended; // Aspect ratio of surface
    FLockRect:  TRect;
    FTransColor: cardinal;
    function GetCurrentSurface: TDirectDrawSurface;
    procedure SetCurrentSurface(aSurface: TDirectDrawSurface);
    procedure SetPixelProc(NewPixelProc: TPixelProc);
  public
    UseAspect: boolean;
    SurfaceDesc: TDDSurfaceDesc2;
    // General surface routines
    constructor Create(ADraw: TDirectDraw);
    destructor Destroy;
    procedure Init( aDXDraw: TDXDraw; aImageList: TDXImageList;
                    aWidth, aHeight: integer;
                    TransColor: cardinal );
    // Utility routines
    procedure LoadFromJpeg(Filename: string; ResizeFromFile: boolean);
    procedure CopyFromSurface(var SrcSurface: TDirectDrawSurface);
    procedure DrawToDXDraw(xp, yp: integer; aTransparent: boolean); virtual;
    // Pixel Format routines
    function RGBToBGR(Color: cardinal): cardinal;
    procedure GetRGB(Color: cardinal; var R, G, B: Byte);
    // Gfx routines
    function Lock: Boolean;
    procedure Unlock;
    procedure PutPixel(x, y: Integer; Color: cardinal); virtual;
    function GetPixel(x, y: Integer) : cardinal; virtual;
    procedure Line(X1, Y1, X2, Y2: Integer; Color: cardinal); virtual;
    procedure VLine(x,y1,y2: integer; Color: cardinal);
    procedure LinePolar(x, y: integer; angle, length: extended; Color: cardinal); virtual;
    procedure CopperBar(y, cbHeight: integer; TopColor, MiddleColor, BottomColor: cardinal); virtual;
    // Collision routines
    function PointInCircle(xp, yp: integer; xCircle, yCircle, Radius: extended): boolean;
    // FX routines
    procedure FlipX; virtual;
    procedure FlipY; virtual;
    // Time savers
    property BitDepth: TBitDepth read FBitDepth;
    property Surface: TDirectDrawSurface read GetCurrentSurface write SetCurrentSurface;
    property PixelProc: TPixelProc write SetPixelProc; // Just testing..DO NOT USE!!!!
  end;


implementation


// ==========================================
// ==           BMPFONT PROCS              ==
// ==========================================

constructor TBmpFont.Create(DestSurface: TDirectDrawSurface);
begin
  inherited Create;
  FSurface:=DestSurface;
  FAspect:=FSurface.Width div FSurface.Height;
end;

destructor TBmpFont.Destroy;
begin
  inherited Destroy;
end;


procedure TBmpFont.Init(aDXDraw: TDXDraw; aImageList: TDXImageList;
                   aNameSet, aNameSet2: string);
begin
  FDXDraw:=aDXDraw;
  FImageList:=aImageList;
  FNameSet:=aNameSet;
  FNameSet2:=aNameSet2;
end;

procedure TBmpFont.TextOut(xp, yp: integer; mess: string; xCentred: boolean);
var
  ctr: integer;
begin
  if xCentred then
    xp:=(FSurface.Width div 2) - ((Length(mess)*FImageList.Items.Find(FNameSet).PatternWidth) div 2);
  With FImageList.Items do
    for ctr:=1 to Length(mess) do
    begin
      if upcase(mess[ctr]) in ['A'..'Z'] then
        Find(FNameSet).Draw(FSurface, xp+((ctr-1)*Find(FNameSet).PatternWidth), yp, ord(upcase(mess[ctr]))-65);
      if mess[ctr] in ['0'..'9'] then
        Find(FNameSet).Draw(FSurface, xp+((ctr-1)*Find(FNameSet).PatternWidth), yp, ord(mess[ctr])-22);
    end;
end;

procedure TBmpFont.PrintChar(xp, yp: integer; aChar: char);
begin
  with FImageList.Items do
  begin
    if upcase(aChar) in ['A'..'Z'] then
      Find(FNameSet).Draw(FSurface, xp, yp, ord(upcase(aChar))-65);
    if aChar in ['0'..'9'] then
      Find(FNameSet).Draw(FSurface, xp, yp, ord(aChar)-22);
  end;
end;

procedure TBmpFont.SetDrawSurface(aSurface: TDirectDrawsurface);
begin
  FSurface:=aSurface;
end;





// ==========================================
// ==        GRAFIXSURFACE PROCS           ==
// ==========================================


constructor TGrafixSurface.Create(ADraw: TDirectDraw);
begin
  inherited Create(ADraw);
end;

destructor TGrafixSurface.Destroy;
begin
  inherited Destroy;
end;


{ INIT THE SURFACE }
procedure TGrafixSurface.Init( aDXDraw: TDXDraw;
                               aImageList: TDXImageList;
                               aWidth,
                               aHeight: integer;
                               TransColor: cardinal );
begin
  FDXDraw:=aDXDraw;
  FImageList:=aImageList;
  FWidth:=aWidth;
  FHeight:=aHeight;
  FSurface:=TGrafixSurface(self);

  FPixelProc:=PutPixel;

  FTransColor:=TransColor;
  FSurface.TransparentColor:=FTransColor;

  if aWidth=0 then FWidth:=FDXDraw.SurfaceWidth;
  if aHeight=0 then FHeight:=FDXDraw.SurfaceHeight;

  setsize(FWidth, FHeight);
  FAspect:=FWidth div FHeight;

  // Determines which mode DXDraw is in
  case FDXDraw.Surface.BitCount of
    8: FBitDepth:=bd8;
    15: FBitDepth:=bd15; // For older cards that use 555 format (Rush)
    16: FBitDepth:=bd16;
    24: FBitDepth:=bd24;