hge.pas

完整的Delphi游戏开发控件

      const Pan: Integer = 0; const Pitch: Single = 1.0; const Loop: Boolean = False): IChannel;

    function Music_Load(const Filename: String): IMusic; overload;
    function Music_Load(const Data: Pointer; const Size: Longword): IMusic; overload;
    function Music_Play(const Mus: IMusic; const Loop: Boolean;
      const Volume: Integer = 100; const Order: Integer = -1;
      const Row: Integer = -1): IChannel;
    procedure Music_SetAmplification(const Music: IMusic; const Ampl: Integer);
    function Music_GetAmplification(const Music: IMusic): Integer;
    function Music_GetLength(const Music: IMusic): Integer;
    procedure Music_SetPos(const Music: IMusic; const Order, Row: Integer);
    function Music_GetPos(const Music: IMusic; out Order, Row: Integer): Boolean;
    procedure Music_SetInstrVolume(const Music: IMusic; const Instr,
      Volume: Integer);
    function Music_GetInstrVolume(const Music: IMusic;
      const Instr: Integer): Integer;
    procedure Music_SetChannelVolume(const Music: IMusic; const Channel,
      Volume: Integer);
    function Music_GetChannelVolume(const Music: IMusic;
      const Channel: Integer): Integer;

    function Stream_Load(const Filename: String): IStream; overload;
    function Stream_Load(const Data: Pointer; const Size: Longword): IStream; overload;
    function Stream_Load(const Resource: IResource; const Size: Longword): IStream; overload;
    function Stream_Play(const Stream: IStream; const Loop: Boolean;
      const Volume: Integer = 100): IChannel;

    procedure Channel_SetPanning(const Chn: IChannel; const Pan: Integer);
    procedure Channel_SetVolume(const Chn: IChannel; const Volume: Integer);
    procedure Channel_SetPitch(const Chn: IChannel; const Pitch: Single);
    procedure Channel_Pause(const Chn: IChannel);
    procedure Channel_Resume(const Chn: IChannel);
    procedure Channel_Stop(const Chn: IChannel);
    procedure Channel_PauseAll;
    procedure Channel_ResumeAll;
    procedure Channel_StopAll;
    function Channel_IsPlaying(const Chn: IChannel): Boolean;
    function Channel_GetLength(const Chn: IChannel): Single;
    function Channel_GetPos(const Chn: IChannel): Single;
    procedure Channel_SetPos(const Chn: IChannel; const Seconds: Single);
    procedure Channel_SlideTo(const Channel: IChannel; const Time: Single;
      const Volume: Integer; const Pan: Integer = -101; const Pitch: Single = -1);
    function Channel_IsSliding(const Channel: IChannel): Boolean;

    procedure Input_GetMousePos(out X, Y: Single);
    procedure Input_SetMousePos(const X, Y: Single);
    function Input_GetMouseWheel: Integer;
    function Input_IsMouseOver: Boolean;
    function Input_KeyDown(const Key: Integer): Boolean;
    function Input_KeyUp(const Key: Integer): Boolean;
    function Input_GetKeyState(const Key: Integer): Boolean;
    function Input_GetKeyName(const Key: Integer): String;
    function Input_GetKey: Integer;
    function Input_GetChar: Integer;
    function Input_GetEvent(out Event: THGEInputEvent): Boolean;

    function Gfx_BeginScene(const Target: ITarget = nil): Boolean;
    procedure Gfx_EndScene;
    procedure Gfx_Clear(const Color: Longword);
    procedure Gfx_RenderLine(const X1, Y1, X2, Y2: Single;
      const Color: Longword = $FFFFFFFF; const Z: Single = 0.5);
    procedure Gfx_RenderTriple(const Triple: THGETriple);
    procedure Gfx_RenderQuad(const Quad: THGEQuad);
    function Gfx_StartBatch(const PrimType: Integer; const Tex: ITexture;
      const Blend: Integer; out MaxPrim: Integer): PHGEVertexArray;
    procedure Gfx_FinishBatch(const NPrim: Integer);
    procedure Gfx_SetClipping(X: Integer = 0; Y: Integer = 0;
      W: Integer = 0; H: Integer = 0);
    procedure Gfx_SetTransform(const X: Single = 0; const Y: Single = 0;
      const DX: Single = 0; const DY: Single = 0; const Rot: Single = 0;
      const HScale: Single = 0; const VScale: Single = 0);

    function Target_Create(const Width, Height: Integer; const ZBuffer: Boolean): ITarget;
    function Target_GetTexture(const Target: ITarget): ITexture;

    function Texture_Create(const Width, Height: Integer): ITexture;
    function Texture_Load(const Data: Pointer; const Size: Longword;
      const Mipmap: Boolean = False): ITexture; overload;
    function Texture_Load(const Filename: String;
      const Mipmap: Boolean = False): ITexture; overload;
    function Texture_GetWidth(const Tex: ITexture; const Original: Boolean = False): Integer;
    function Texture_GetHeight(const Tex: ITexture; const Original: Boolean = False): Integer;
    function Texture_Lock(const Tex: ITexture; const ReadOnly: Boolean = True;
      const Left: Integer = 0; const Top: Integer = 0; const Width: Integer = 0;
      const Height: Integer = 0): PLongword;
    procedure Texture_Unlock(const Tex: ITexture);

    { Extensions }
    function Texture_Load(const ImageData: Pointer; const ImageSize: Longword;
      const AlphaData: Pointer; const AlphaSize: Longword;
      const Mipmap: Boolean = False): ITexture; overload;
    function Texture_Load(const ImageFilename, AlphaFilename: String;
      const Mipmap: Boolean = False): ITexture; overload;
    //2008 Nov
    procedure SetGamma(Red, Green, Blue, Brightness, Contrast: Byte);
    procedure Point(X, Y: Single; Color: Cardinal; BlendMode: Integer=BLEND_DEFAULT);
    procedure Line2Color(X1, Y1, X2, Y2: Single; Color1, Color2: Cardinal; BlendMode: Integer);
    procedure Circle(X, Y, Radius: Single; Color: Cardinal; Filled: Boolean;
      BlendMode: Integer = BLEND_Default); overload;
    procedure Circle(X, Y, Radius: Single; Width: Integer; Color: Cardinal;
      Filled: Boolean; BlendMode: Integer=BLEND_DEFAULT); overload;
    procedure Ellipse(X, Y, R1, R2: Single; Color: Cardinal; Filled: Boolean;
      BlendMode: Integer=BLEND_DEFAULT);
    procedure Arc(X, Y, Radius, StartRadius, EndRadius: Single; Color: Cardinal;
      DrawStartEnd, Filled: Boolean; BlendMode: Integer=BLEND_DEFAULT );overload;
    procedure Arc(X, Y, Radius, StartRadius, EndRadius: Single; Color: Cardinal;
      Width: Integer; DrawStartEnd, Filled: Boolean; BlendMode: Integer=BLEND_DEFAULT );overload;
    procedure Triangle(X1, Y1, X2, Y2, X3, Y3: Single; Color: Cardinal;
      Filled: Boolean; BlendMode: Integer=BLEND_DEFAULT);
    procedure Quadrangle4Color(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Single;
      Color1, Color2, Color3, Color4: Cardinal; Filled: Boolean; BlendMode: Integer=BLEND_DEFAULT );
    procedure Quadrangle(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Single; Color: Cardinal;
      Filled: Boolean; BlendMode: Integer=BLEND_DEFAULT);
    procedure Rectangle(X, Y, Width, Height: Single; Color: Cardinal; Filled: Boolean;
      BlendMode: Integer=BLEND_DEFAULT);
    procedure Polygon(Points: array of TPoint; NumPoints: Integer; Color: Cardinal;
      Filled: Boolean; BlendMode: Integer=BLEND_DEFAULT); overload;
    procedure Polygon(Points: array of TPoint; Color: Cardinal; Filled: Boolean;
      BlendMode: Integer=BLEND_DEFAULT); overload;
  private
    //////// Implementation ////////
    Vertices: array[0..1000] of THGEVertex;

    FInstance: THandle;
    FWnd: HWnd;
    FActive: Boolean;
    FError: String;
    FAppPath: String;
    FFormatSettings: TFormatSettings;
    procedure CopyVertices(pVertices: PByte; numVertices: integer);
    procedure FocusChange(const Act: Boolean);
    procedure PostError(const Error: String);
    class function InterfaceGet: THGEImpl;
  private
    // Extensions
    function Texture_LoadJPEG2000(const Data: Pointer; const Size: Longword;
      const Mipmap: Boolean; const Format: TOPJ_CodecFormat): ITexture;
  private
    // System States
    FProcFrameFunc: THGECallback;
    FProcRenderFunc: THGECallback;
    FProcFocusLostFunc: THGECallback;
    FProcFocusGainFunc: THGECallback;
    FProcGfxRestoreFunc: THGECallback;
    FProcExitFunc: THGECallback;
    FIcon: String;
    FWinTitle: String;
    FScreenWidth: Integer;
    FScreenHeight: Integer;
    FScreenBPP: Integer;
    FWindowed: Boolean;
    FZBuffer: Boolean;
    FTextureFilter: Boolean;
    FIniFile: String;
    FLogFile: String;
    FUseSound: Boolean;
    FSampleRate: Integer;
    FFXVolume: Integer;
    FMusVolume: Integer;
    FHGEFPS: Integer;
    FHideMouse: Boolean;
    FDontSuspend: Boolean;
    FWndParent: HWnd;
    {$IFDEF DEMO}
    FDMO: Boolean;
    {$ENDIF}
  private
    // Graphics
    FD3DPP: PD3DPresentParameters;
    FD3DPPW: TD3DPresentParameters;
    FRectW: TRect;
    FStyleW: Longword;
    FD3DPPFS: TD3DPresentParameters;
    FRectFS: TRect;
    FStyleFS: Longword;
    FD3D: IDirect3D8;
    FD3DDevice: IDirect3DDevice8;
    FVB: IDirect3DVertexBuffer8;
    FIB: IDirect3DIndexBuffer8;
    FScreenSurf: IDirect3DSurface8;
    FScreenDepth: IDirect3DSurface8;
    FTargets: TList;
    FCurTarget: ITarget;
    FMatView: TD3DXMatrix;
    FMatProj: TD3DXMatrix;
    FVertArray: PHGEVertexArray;
    FPrim: Integer;
    FCurPrimType: Integer;
    FCurBlendMode: Integer;
    FCurTexture: ITexture;
    function GfxInit: Boolean;
    procedure GfxDone;
    function GfxRestore: Boolean;
    procedure AdjustWindow;
    procedure Resize(const Width, Height: Integer);
    function InitLost: Boolean;
    procedure RenderBatch(const EndScene: Boolean = False);
    function FormatId(const Fmt: TD3DFormat): Integer;
    procedure SetBlendMode(const Blend: Integer);
    procedure SetProjectionMatrix(const Width, Height: Integer);
  private
     // Audio
    FBass: THandle;
    FSilent: Boolean;
    function SoundInit: Boolean;
    procedure SoundDone;
    procedure SetMusVolume(const Vol: Integer);
    procedure SetFXVolume(const Vol: Integer);
  private
    // Input
    FVKey: Integer;
    FChar: Integer;
    FZPos: Integer;
    FXPos: Single;
    FYPos: Single;
    FMouseOver: Boolean;
    FCaptured: Boolean;
    FKeyz: array [0..255] of Byte;
    FQueue: PInputEventList;
    procedure UpdateMouse;
    procedure InputInit;
    procedure ClearQueue;
    procedure BuildEvent(EventType, Key, Scan, Flags, X, Y: Integer);
  private
    // Resource
    FTmpFilename: String;
    FRes: PResourceList;
    FSearch: TSearchRec;
  private
    // Timer
    FTime: Single;
    FDeltaTime: Single;
    FFixedDelta: Longword;
    FFPS: Integer;
    FT0, FT0FPS, FDT: Longword;
    FCFPS: Integer;
  private
    constructor Create;
  public
    destructor Destroy; override;
  end;

var
  PHGE: THGEImpl = nil;



type
  IInternalChannel = interface(IChannel)
  ['{F7EFCB72-56E5-4FED-A89A-4B1D0AEE794D}']
    procedure SetHandle(const Value: HChannel);
  end;

type
  IInternalTarget = interface(ITarget)
  ['{579FDCE5-3D0C-403F-9B58-44117B226A26}']
    function GetDepth: IDirect3DSurface8;

    procedure Restore;
    procedure Lost;

    property Depth: IDirect3DSurface8 read GetDepth;
  end;

type
  IInternalStream = interface(IStream)
  ['{37BFE886-0402-4CB7-B2A1-46D1C2ED0D82}']
    function GetData: IResource;

    property Data: IResource read GetData;
  end;



type
  TTexture = class(TInterfacedObject,ITexture)
  private
    FName: string;
    FPatternWidth: Integer;
    FPatternHeight: Integer;
    FPatternCount: Integer;
    FHandle: IDirect3DTexture8;
    FOriginalWidth: Integer;
    FOriginalHeight: Integer;
  protected
    { ITexture }
    function GetName: string;
    procedure SetName(Value: string);
    function GetPatternWidth: Integer;
    procedure SetPatternWidth(Value: Integer);
    function GetPatternHeight: Integer;
    procedure SetPatternHeight(Value: Integer);
    function GetPatternCount: Integer;
    function GetHandle: IDirect3DTexture8;
    procedure SetHandle(const Value: IDirect3DTexture8);
    function GetWidth(const Original: Boolean = False): Integer;
    function GetHeight(const Original: Boolean = False): Integer;
    function Lock(const ReadOnly: Boolean = True; const Left: Integer = 0;
      const Top: Integer = 0; const Width: Integer = 0;
      const Height: Integer = 0): PLongword;
    procedure Unlock;
  public
    constructor Create(const AHandle: IDirect3DTexture8;
      const AOriginalWidth, AOriginalHeight: Integer);
    property Name:string read GetName write SetName;
    property PatternWidth: Integer read GetPatternWidth write SetPatternWidth;
    property PatternHeight: Integer read GetPatternHeight write SetPatternHeight;
    property PatternCount: Integer read GetPatternCount;
  end;

type
  TChannel = class(TInterfacedObject,IChannel,IInternalChannel)
  private
    FHandle: HChannel;
  protected
    { IChannel }
    function GetHandle: HChannel;
    procedure SetPanning(const Pan: Integer);
    procedure SetVolume(const Volume: Integer);
    procedure SetPitch(const Pitch: Single);
    procedure Pause;
    procedure Resume;
    procedure Stop;
    function IsPlaying: Boolean;
    function IsSliding: Boolean;
    function GetLength: Single;
    function GetPos: Single;
    procedure SetPos(const Seconds: Single);
    procedure SlideTo(const Time: Single; const Volume: Integer;
      const Pan: Integer = -101; const Pitch: Single = -1);

    { IInternalChannel }
    procedure SetHandle(const Value: HChannel);
  public
    constructor Create(const AHandle: HChannel);
    destructor Destroy; override;
  end;

type
  TEffect = class(TInterfacedObject,IEffect)
  private
    FHandle: HSample;
    FChannel: IInternalChannel;
  protected
    { IEffect }
    function GetHandle: HSample;
    function Play: IChannel;
    function PlayEx(const Volume: Integer = 100; const Pan: Integer = 0;
      const Pitch: Single = 1.0; const Loop: Boolean = False): IChannel;
  public
    constructor Create(const AHandle: HSample);
    destructor Destroy; override;
  end;

type
  TMusic = class(TChannel,IMusic,IChannel)
  private
    function MusicGetLength: Integer;
    procedure MusicSetPos(const Order, Row: Integer);
    function MusicGetPos(out Order, Row: Integer): Boolean;
  protected
    { IMusic }
    function Play(const Loop: Boolean; const Volume: Integer = 100;
      const Order: Integer = -1; const Row: Integer = -1): IChannel;
    function GetAmplification: Integer;
    function IMusic.GetLength = MusicGetLength;
    procedure IMusic.SetPos = MusicSetPos;
    function IMusic.GetPos = MusicGetPos;
    procedure SetInstrVolume(const Instr, Volume: Integer);
    function GetInstrVolume(const Instr: Integer): Integer;
    procedure SetChannelVolume(const Channel, Volume: Integer);
    function GetChannelVolume(const Channel: Integer): Integer;
  public
    destructor Destroy; override;
  end;

type
  TTarget = class(TInterfacedObject,ITarget,IInternalTarget)
  private
    FWidth: Integer;
    FHeight: Integer;
    FTex: ITexture;
    FDepth: IDirect3DSurface8;
  protected
    { ITarget }
    function GetWidth: Integer;
    function GetHeight: Integer;
    function GetTex: ITexture;
    function GetTexture: ITexture;
    { IInternalTarget }
    function GetDepth: IDirect3DSurface8;
    procedure Restore;
    procedure Lost;
  public
    constructor Create(const AWidth, AHeight: Integer; const ATex: ITexture;
      const ADepth: IDirect3DSurface8);
    destructor Destroy; override;
  end;

type
  TStream = class(TChannel,IStream,IInternalStream,IChannel)
  private
    FData: IResource;
  protected
    { IStream }
    function Play(const Loop: Boolean; const Volume: Integer = 100): IChannel;
    { IInternalStream }
    function GetData: IResource;