hge.pas

完整的Delphi游戏开发控件

  public
    constructor Create(const AHandle: HStream; const AData: IResource);
    destructor Destroy; override;
  end;

type
  TResource = class(TInterfacedObject,IResource)
  private
    FHandle: Pointer;
    FSize: Longword;
  protected
    { IResource }
    function GetHandle: Pointer;
    function GetSize: Longword;
  public
    constructor Create(const AHandle: Pointer; const ASize: Longword);
    destructor Destroy; override;
  end;

{TSysFont}
function TSysFont.CreateFont(FontName: string; Size: Integer; Style: TFontStyles): Boolean;
begin
  FName := FontName;
  FSize := Size;
  FStyle := Style;
  FRed:= 255;
  FGreen := 255;
  FBlue := 255;
  FAlpha := 255;
  Result := True;
  UnInit;
  Init;
end;

function TSysFont.CreateFont(const Font: TFont): Boolean;
begin
  if not Assigned(Font) then
   raise Exception.Create('CreateFont() had unassigned Font param.');
  Result := CreateFont(Font.Name, Font.Size, Font.Style);
end;

procedure TSysFont.BeginFont;
begin
  if not Assigned(FFont) then Exit;
  FFont._Begin;
end;

procedure TSysFont.SetColor(const Value: Cardinal);
begin
  FColor := Value;
  Red := SetR(FColor, FRed);
  Blue := SetB(FColor, FBlue);
  Green:= SetG(FColor, FGreen);
  Alpha := SetA(FColor,FAlpha);
end;

procedure TSysFont.EndFont;
begin
  if not Assigned(FFont) then Exit;
  FFont._End;
end;

procedure TSysFont.Print(XPos, YPos: Integer; sString: string; R, G, B, A: Byte);
var
  Rect: TRect;
begin
  if not Assigned(FFont) then Exit;
  Rect.Left := XPos;
  Rect.Top := YPos;
  Rect.Bottom := 0;
  Rect.Right := 0;
  FFont.DrawTextA(PChar(sString), -1, Rect, DT_NOCLIP, D3dColor_RGBA(R, G, B, A));
end;

procedure TSysFont.Print(XPos, YPos: Integer; sString: string);
begin
  Print(XPos, YPos, sString, FRed, FGreen, FBlue, FAlpha);
end;

procedure TSysFont.Print(Pos: TPoint; sString: string);
begin
  Print(Pos.X, Pos.Y, sString);
end;

procedure TSysFont.PrintInvert(XPos, YPos: Integer; sString: string);
begin
   Print(XPos, YPos, sString, (255 - FRed), (255 - FGreen), (255 - FBlue), FAlpha);
end;

destructor TSysFont.Destroy;
begin
  UnInit;
  inherited Destroy;
end;

function TSysFont.TextHeight(const Text: string): Integer;
begin
  FCanvas.Font := FTheFont;
  Result := FCanvas.TextHeight(Text);
end;

function TSysFont.TextWidth(const Text: string): Integer;
begin
  FCanvas.Font := FTheFont;
  Result := FCanvas.TextWidth(Text);
end;

procedure TSysFont.Init;
var
  oFont: TFont;
begin
  oFont := TFont.Create;
  try
    oFont.Name := FName;
    oFont.Size := FSize;
    oFont.Style := FStyle;
    D3DXCreateFont(PHGE.FD3DDevice, oFont.Handle, FFont);
  finally
    oFont.Free;
  end;

  FCanvas := TCanvas.Create;
  FCanvas.Handle := GetWindowDC(PHGE.System_GetState(HGE_HWND));
  FTheFont := TFont.Create;
  FTheFont.Name := FName;
  FTheFont.Size := FSize;
  FTheFont.Style := FStyle;
end;

procedure TSysFont.UnInit;
begin
  if Assigned(FFont) then FFont := nil;
  if Assigned(FCanvas) then
  begin
    FCanvas.Free;
    FCanvas := nil;
  end;
  if Assigned(FTheFont) then
  begin
    FTheFont.Free;
    FTheFont := nil;
  end;
end;

{ TTexture }

constructor TTexture.Create(const AHandle: IDirect3DTexture8;
  const AOriginalWidth, AOriginalHeight: Integer);
begin
  inherited Create;
  FHandle := AHandle;
  FOriginalWidth := AOriginalWidth;
  FOriginalHeight := AOriginalHeight;
end;

function TTexture.GetName: string;
begin
  Result := FName;
end;

procedure TTexture.SetName(Value: string);
begin
  FName := Value;
end;

function TTexture.GetPatternWidth: Integer;
begin
  Result := FPatternWidth;
end;

procedure TTexture.SetPatternWidth(Value: Integer);
begin
  FPatternWidth := Value;
end;

function TTexture.GetPatternHeight: Integer;
begin
  Result := FPatternHeight;
end;

procedure TTexture.SetPatternHeight(Value: Integer);
begin
  FPatternHeight := Value;
end;

function TTexture.GetPatternCount: Integer;
var
  RowCount, ColCount: Integer;
begin
  ColCount := Self.GetWidth(True) div FPatternWidth;
  RowCount := Self.GetHeight(True) div FPatternHeight;
  if Self.FPatternCount < 0 then Self.FPatternCount := 0;
  //Make drawrect point to last rectangle if it is higher
  //if Self.FPatternCount > RowCount * ColCount then
    Result := RowCount * ColCount;
end;

function TTexture.GetHandle: IDirect3DTexture8;
begin
  Result := FHandle;
end;

function TTexture.GetHeight(const Original: Boolean): Integer;
var
  Desc: TD3DSurfaceDesc;
begin
  if (Original) then
    Result := FOriginalHeight
  else if (Succeeded(FHandle.GetLevelDesc(0,Desc))) then
    Result := Desc.Height
  else
    Result := 0;
end;

function TTexture.GetWidth(const Original: Boolean): Integer;
var
  Desc: TD3DSurfaceDesc;
begin
  if (Original) then
    Result := FOriginalWidth
  else if (Succeeded(FHandle.GetLevelDesc(0,Desc))) then
    Result := Desc.Width
  else
    Result := 0;
end;

function TTexture.Lock(const ReadOnly: Boolean; const Left, Top, Width,
  Height: Integer): PLongword;
var
  Desc: TD3DSurfaceDesc;
  Rect: TD3DLockedRect;
  Region: TRect;
  PRec: PRect;
  Flags: Integer;
begin
  Result := nil;
  FHandle.GetLevelDesc(0,Desc);
  if (Desc.Format <> D3DFMT_A8R8G8B8) and (Desc.Format <> D3DFMT_X8R8G8B8) then
    Exit;

  if (Width <> 0) and (Height <> 0) then begin
    Region.Left := Left;
    Region.Top := Top;
    Region.Right := Left + Width;
    Region.Bottom := Top + Height;
    PRec := @Region;
  end else
    PRec := nil;

  if (ReadOnly) then
    Flags := D3DLOCK_READONLY
  else
    Flags := 0;

  if (Failed(FHandle.LockRect(0,Rect,PRec,Flags))) then
    PHGE.PostError('Can''t lock texture')
  else
    Result := Rect.pBits;
end;

procedure TTexture.SetHandle(const Value: IDirect3DTexture8);
begin
  FHandle := Value;
end;

procedure TTexture.Unlock;
begin
  FHandle.UnlockRect(0);
end;

{ TChannel }

constructor TChannel.Create(const AHandle: HChannel);
begin
  inherited Create;
  FHandle := AHandle;
end;

destructor TChannel.Destroy;
begin
  FHandle := 0;
  inherited;
end;

function TChannel.GetHandle: HChannel;
begin
  Result := FHandle;
end;

function TChannel.GetLength: Single;
begin
  if (PHGE.FBass <> 0) then
    Result := BASS_ChannelBytes2Seconds(FHandle,BASS_ChannelGetLength(FHandle))
  else
    Result := -1;
end;

function TChannel.GetPos: Single;
begin
  if (PHGE.FBass <> 0) then
    Result := BASS_ChannelBytes2Seconds(FHandle,BASS_ChannelGetPosition(FHandle))
  else
    Result := -1;
end;

function TChannel.IsPlaying: Boolean;
begin
  if (PHGE.FBass <> 0) then
    Result := (BASS_ChannelIsActive(FHandle) = BASS_ACTIVE_PLAYING)
  else
    Result := False;
end;

function TChannel.IsSliding: Boolean;
begin
  if (PHGE.FBass <> 0) then
    Result := (BASS_ChannelIsSliding(FHandle) <> 0)
  else
    Result := False;
end;

procedure TChannel.Pause;
begin
  if (PHGE.FBass <> 0) then
    BASS_ChannelPause(FHandle);
end;

procedure TChannel.Resume;
begin
  if (PHGE.FBass <> 0) then
    BASS_ChannelPlay(FHandle,False);
end;

procedure TChannel.SetHandle(const Value: HChannel);
begin
  FHandle := Value;
end;

procedure TChannel.SetPanning(const Pan: Integer);
begin
  if (PHGE.FBass <> 0) then
    BASS_ChannelSetAttributes(FHandle,-1,-1,Pan);
end;

procedure TChannel.SetPitch(const Pitch: Single);
var
  Info: BASS_CHANNELINFO;
begin
  if (PHGE.FBass <> 0) then begin
    BASS_ChannelGetInfo(FHandle,Info);
    BASS_ChannelSetAttributes(FHandle,Trunc(Pitch * Info.freq),-1,-101);
  end;
end;

procedure TChannel.SetPos(const Seconds: Single);
begin
  if (PHGE.FBass <> 0) then
    BASS_ChannelSetPosition(FHandle,BASS_ChannelSeconds2Bytes(FHandle,Seconds));
end;

procedure TChannel.SetVolume(const Volume: Integer);
begin
  if (PHGE.FBass <> 0) then
    BASS_ChannelSetAttributes(FHandle,-1,Volume,-101);
end;

procedure TChannel.SlideTo(const Time: Single; const Volume, Pan: Integer;
  const Pitch: Single);
var
  Freq: Integer;
  Info: BASS_CHANNELINFO;
begin
  if (PHGE.FBass <> 0) then begin
    BASS_ChannelGetInfo(FHandle,Info);
    if (Pitch = -1) then
      Freq := -1
    else
      Freq := Trunc(Pitch * Info.Freq);
    BASS_ChannelSlideAttributes(FHandle,Freq,Volume,Pan,Trunc(Time * 1000));
  end;
end;

procedure TChannel.Stop;
begin
  if (PHGE.FBass <> 0) then
    BASS_ChannelStop(FHandle);
end;

{ TEffect }

constructor TEffect.Create(const AHandle: HSample);
begin
  inherited Create;
  FHandle := AHandle;
  FChannel := TChannel.Create(0);
end;

destructor TEffect.Destroy;
begin
  if (PHGE.FBass <> 0) then
    BASS_SampleFree(FHandle);
  FHandle := 0;
  inherited;
end;

function TEffect.GetHandle: HSample;
begin
  Result := FHandle;