{******************************************************************************}
{* Иллюстрация к книге "DirectX. Графика в проектах Delphi".                  *}
{* Издательство BHV. www.bhv.ru                                               *}
{* Краснов М.В. softgl@chat.ru                                                *}
{******************************************************************************}
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  AppEvnts, ExtCtrls,
  DirectDraw, DDUtil;

type
  TfrmDD = class(TForm)
    ApplicationEvents1: TApplicationEvents;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure ApplicationEvents1Idle(Sender: TObject; var Done: Boolean);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
    FDD            : IDirectDraw7;
    FDDSPrimary    : IDirectDrawSurface7;
    FDDSImage      : IDirectDrawSurface7;
    FDDSLogo       : IDirectDrawSurface7;
    FDDSBack       : IDirectDrawSurface7;
    ThisTickCount  : DWORD;
    LastTickCount  : DWORD;
    HalfWidth      : Integer;
    HalfHeight     : Integer;
    PixelFormat    : TDDPixelFormat;
    wrkBitmap      : TBitmap;
    function UpdateFrame : HRESULT;
    function RestoreAll : HRESULT;
    procedure ErrorOut(hRet : HRESULT; FuncName : String);
    function RotateBmp(const BitmapOriginal : TBitmap;
                       const iRotationAxis, jRotationAxis : Integer;
                       const AngleOfRotation: Single): TBitmap;
  public
    { Public declarations }
  end;

const
  imageBmp  = 'Earth.bmp';
  logoBmp   = 'Logo.bmp';
  TimeDelay = 10;

var
  frmDD : TfrmDD;
  Angle : Single = 0.0;

implementation

{$R *.DFM}

procedure TfrmDD.ErrorOut(hRet : HRESULT; FuncName : String);
var
  t : TextFile;
begin
  AssignFile (t, 'Debug.txt');
  Rewrite (t);
  WriteLn (t, FuncName + ': ' + DDErrorString (hRet));
  CloseFile (t);
  Destroy;
end;

procedure TfrmDD.FormCreate(Sender: TObject);
var
  hRet : HRESULT;
  ddsd : TDDSurfaceDesc2;
  ddbltfx : TDDBLTFX;
begin
  FDDSBack := nil;
  FDDSLogo := nil;
  FDDSImage := nil;
  FDDSPrimary := nil;
  FDD := nil;

  hRet := DirectDrawCreateEx (nil, FDD, IDirectDraw7, nil);
  if Failed(hRet) then ErrorOut(hRet, 'DirectDrawCreateEx');

  hRet := FDD.SetCooperativeLevel(Handle, DDSCL_NORMAL);
  if Failed(hRet) then ErrorOut(hRet, 'SetCooperativeLevel');

  ZeroMemory(@ddsd, SizeOf(ddsd));
  with ddsd do begin
       dwSize := SizeOf(ddsd);
       dwFlags := DDSD_CAPS;
       ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE;
  end;
  hRet := FDD.CreateSurface(ddsd, FDDSPrimary, nil);
  if Failed(hRet) then ErrorOut(hRet, 'Create Primary Surface');

  ZeroMemory (@PixelFormat, SizeOf(PixelFormat));
  PixelFormat.dwSize := SizeOf(PixelFormat);
  hRet := FDDSPrimary.GetPixelFormat(PixelFormat);
  if Failed (hRet) then ErrorOut(hRet, 'GetPixelFormat');

  FDDSImage := DDLoadBitmap(FDD, imageBMP, 0, 0);
  if FDDSImage = nil then ErrorOut(DD_FALSE, 'DDLoadBitmap');

  hRet := DDSetColorKey (FDDSImage, RGB(0, 0, 0));
  if Failed (hRet) then ErrorOut(hRet, 'DDSetColorKey');

  ZeroMemory(@ddsd, SizeOf(ddsd));
  with ddsd do begin
     dwSize := SizeOf(ddsd);
     dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH or DDSD_PIXELFORMAT;
     ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
     dwWidth  := 256;
     dwHeight := 256;
     ddpfPixelFormat := PixelFormat;
  end;
  hRet := FDD.CreateSurface(ddsd, FDDSBack, nil);
  if Failed(hRet) then ErrorOut(hRet, 'Create Back Surface');

  hRet := DDSetColorKey (FDDSBack, RGB(0, 0, 0));
  if Failed (hRet) then ErrorOut(hRet, 'DDSetColorKey');

  hRet := FDD.CreateSurface(ddsd, FDDSLogo, nil);
  if Failed(hRet) then ErrorOut(hRet, 'Create Back Surface');

  hRet := DDSetColorKey (FDDSLogo, RGB(0, 0, 0));
  if Failed (hRet) then ErrorOut(hRet, 'DDSetColorKey');

  ZeroMemory(@ddbltfx, SizeOf(ddbltfx));
  ddbltfx.dwSize := SizeOf(ddbltfx);
  ddbltfx.dwFillColor := 0;
  FDDSBack.Blt(nil, nil, nil, DDBLT_COLORFILL or DDBLT_WAIT, @ddbltfx);

  HalfWidth  := (GetSystemMetrics(SM_CXSCREEN) - 256) div 2;
  HalfHeight := (GetSystemMetrics(SM_CYSCREEN) - 256) div 2;

  wrkBitmap := TBitmap.Create;
  wrkBitmap.LoadFromFile (logoBMP);
end;

procedure TfrmDD.FormDestroy(Sender: TObject);
begin
  if Assigned(FDD) then begin
      if Assigned(FDDSBack) then begin
         FDDSBack._Release;
         FDDSBack := nil;
      end;
      if Assigned(FDDSLogo) then begin
         FDDSLogo._Release;
         FDDSLogo := nil;
      end;
      if Assigned(FDDSImage) then begin
         FDDSImage._Release;
         FDDSImage := nil;
      end;
      if Assigned(FDDSPrimary) then begin
         FDDSPrimary._Release;
         FDDSPrimary := nil;
      end;
      FDD._Release;
      FDD := nil;
  end;
  wrkBitmap.Free;
end;

procedure TfrmDD.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (Key = VK_ESCAPE) or (Key = VK_F12) then Close;
end;

function TfrmDD.RestoreAll : HRESULT;
var
  hRet : HRESULT;
begin
  hRet := FDDSPrimary._Restore;
  if Succeeded (hRet) then begin
      hRet := FDDSBack._Restore;
      if Failed (hRet) then begin
         Result := hRet;
         Exit;
      end;
      hRet := FDDSLogo._Restore;
      if Failed (hRet) then begin
         Result := hRet;
         Exit;
      end;
      hRet := FDDSImage._Restore;
      if Failed (hRet) then begin
         Result := hRet;
         Exit;
      end;
      Result := DDReLoadBitmap(FDDSImage, imageBmp);
  end
  else Result := hRet;
end;

function TfrmDD.UpdateFrame : HRESULT;
begin
  with RotateBmp (wrkBitmap, 128, 128, Angle) do begin
       DDCopyBitmap (FDDSLogo, Handle, 0, 0, Width, Height);
       Free
  end;
  Angle := Angle - 0.1;
  if Angle > - 2 * Pi then Angle := Angle + 2 * Pi;

  FDDSBack.BltFast(0, 0, FDDSImage, nil, DDBLTFAST_WAIT or DDBLTFAST_SRCCOLORKEY);
  FDDSBack.BltFast(0, 0, FDDSLogo, nil, DDBLTFAST_WAIT or DDBLTFAST_SRCCOLORKEY);
  Result := FDDSPrimary.BltFast(HalfWidth, HalfHeight, FDDSBack, nil, DDBLTFAST_WAIT or DDBLTFAST_SRCCOLORKEY);
end;

procedure TfrmDD.ApplicationEvents1Idle(Sender: TObject;
  var Done: Boolean);
begin
  ThisTickCount := GetTickCount;
  if ThisTickCount - LastTickCount > TimeDelay then begin
     if Failed (UpdateFrame) then RestoreAll;
     LastTickCount := GetTickCount;
  end;
  Done := False;
end;

function TfrmDD.RotateBmp (const BitmapOriginal: TBitmap;
                           const iRotationAxis, jRotationAxis: Integer;
                           const AngleOfRotation: Single): TBitmap;
const
  MaxPixelCount = 32768;
type
  TRGBTripleArray = Array [0..MaxPixelCount-1] of TRGBTriple;
  pRGBTripleArray = ^TRGBTripleArray;
var
  cosTheta    : Single;
  i           : Integer;
  iOriginal   : Integer;
  iPrime      : Integer;
  j           : Integer;
  jOriginal   : Integer;
  jPrime      : Integer;
  RowOriginal : pRGBTripleArray;
  RowRotated  : pRGBTRipleArray;
  sinTheta    : Single;
begin
  Result := TBitmap.Create;
  Result.Width := BitmapOriginal.Width;
  Result.Height := BitmapOriginal.Height;
  Result.PixelFormat := pf24bit;

  sinTheta := sin (AngleOfRotation);
  cosTheta := cos (AngleOfRotation);

  for j := Result.Height - 1 downto 0 do begin
    RowRotated := Result.Scanline[j];
    jPrime := j - jRotationAxis;

    for i := Result.Width-1 downto 0 do begin
      iPrime := i - iRotationAxis;
      iOriginal := iRotationAxis + round(iPrime * CosTheta - jPrime *
sinTheta);
      jOriginal := jRotationAxis + round(iPrime * sinTheta + jPrime *
cosTheta);

      if (iOriginal >= 0) and (iOriginal <= BitmapOriginal.Width-1) and
          (jOriginal >= 0) and (jOriginal <= BitmapOriginal.Height-1)
      then begin
        RowOriginal := BitmapOriginal.Scanline[jOriginal];
        RowRotated[i] := RowOriginal[iOriginal]
      end
      else begin
        RowRotated[i].rgbtBlue := 0;
        RowRotated[i].rgbtGreen := 0;
        RowRotated[i].rgbtRed := 0
     end
    end
  end;
end;

procedure TfrmDD.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Left := HalfWidth;
  Top := HalfHeight;
  Width := 256;
  Height := 256;
end;

end.

