{******************************************************************************}
{* Иллюстрация к книге "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 ApplicationEvents1Deactivate(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure ApplicationEvents1Restore(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure ApplicationEvents1Idle(Sender: TObject; var Done: Boolean);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
    FDD            : IDirectDraw7;
    FDDSBack       : IDirectDrawSurface7;
    FDDSImage1     : IDirectDrawSurface7;
    FDDSImage2     : IDirectDrawSurface7;
    FDDSImage3     : IDirectDrawSurface7;
    FDDSFighter    : IDirectDrawSurface7;
    FDDSPrimary    : IDirectDrawSurface7;
    wrkBitmap      : TBitmap;
    FActive        : BOOL;
    ThisTickCount  : DWORD;
    LastTickCount  : DWORD;
    function UpdateFrame : HRESULT;
    function FlipPages : HRESULT;
    function RestoreAll : HRESULT;
    procedure ErrorOut(hRet : HRESULT; FuncName : String);
    function Clear : HRESULT;
    function RotateBmp (const BitmapOriginal: TBitmap;
                           const iRotationAxis, jRotationAxis: Integer;
                           const AngleOfRotation: Single): TBitmap;
  public
    { Public declarations }
  protected
    procedure FormSetCursor(var aMsg : TMessage); message WM_SETCURSOR;
  end;

const
  ScreenWidth    = 640;
  ScreenHeight   = 480;
  ScreenBitDepth = 16;
  StarBmp1       = 'Star1.bmp';
  StarBmp2       = 'Star2.bmp';
  StarBmp3       = 'Star3.bmp';
  FighterBmp     = 'Fighter.bmp';
  NumStars       = 10;

var
  frmDD : TfrmDD;
  StepX : Integer = 0;
  StepY : Integer = 1;

type
  TCoord = record
     X, Y : Integer;
  end;

var
  Stars1 : Array [0..NumStars - 1] of TCoord;
  Stars2 : Array [0..NumStars - 1] of TCoord;
  Stars3 : Array [0..NumStars - 1] of TCoord;  

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;
  ddscaps : TDDSCaps2;
  i : Integer;
begin
  FDDSFighter := nil;
  FDDSImage3 := nil;
  FDDSImage2 := nil;
  FDDSImage1 := nil;
  FDDSBack := nil;
  FDDSPrimary := nil;
  FDD := nil;

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

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

  hRet := FDD.SetDisplayMode (ScreenWidth, ScreenHeight, ScreenBitDepth, 0, 0);
  if Failed (hRet) then ErrorOut(hRet, 'SetDisplayMode');

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

  ZeroMemory(@ddscaps, SizeOf(ddscaps));
  ddscaps.dwCaps := DDSCAPS_BACKBUFFER;
  hRet := FDDSPrimary.GetAttachedSurface(ddscaps, FDDSBack);
  if Failed (hRet) then ErrorOut(hRet, 'GetAttachedSurface');

  FDDSBack._AddRef;

  FDDSImage1 := DDLoadBitmap(FDD, StarBmp1, 0, 0);
  if FDDSImage1 = nil then ErrorOut(DD_FALSE, 'DDLoadBitmap');

  FDDSImage2 := DDLoadBitmap(FDD, StarBmp2, 0, 0);
  if FDDSImage2 = nil then ErrorOut(DD_FALSE, 'DDLoadBitmap');

  FDDSImage3 := DDLoadBitmap(FDD, starBmp3, 0, 0);
  if FDDSImage3 = nil then ErrorOut(DD_FALSE, 'DDLoadBitmap');

  wrkBitmap := TBitMap.Create;
  wrkBitmap.LoadFromFile (FighterBmp);

  ZeroMemory(@ddsd, SizeOf(ddsd));
  with ddsd do begin
     dwSize := SizeOf(ddsd);
     dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH;
     ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
     dwWidth  := wrkBitmap.Width;
     dwHeight := wrkBitmap.Height;
  end;
  hRet := FDD.CreateSurface(ddsd, FDDSFighter, nil);
  if Failed(hRet) then ErrorOut(hRet, 'Create Fighter Surface');

  hRet := DDCopyBitmap (FDDSFighter, wrkBitmap.Handle, 0, 0, wrkBitmap.Width, wrkBitmap.Height);
  if Failed(hRet) then ErrorOut(hRet, 'DDCopyBitmap');

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

  Randomize;

  for i := 0 to NumStars - 1 do begin
      Stars1 [i].X := random (ScreenWidth);
      Stars1 [i].Y := random (ScreenHeight);
      Stars2 [i].X := random (ScreenWidth);
      Stars2 [i].Y := random (ScreenHeight);
      Stars3 [i].X := random (ScreenWidth);
      Stars3 [i].Y := random (ScreenHeight);
  end;
end;

procedure TfrmDD.FormDestroy(Sender: TObject);
begin
  if Assigned(FDD) then begin
      if Assigned(FDDSFighter) then begin
         FDDSFighter._Release;
         FDDSFighter := nil;
      end;
      if Assigned(FDDSImage3) then begin
         FDDSImage3._Release;
         FDDSImage3 := nil;
      end;
      if Assigned(FDDSImage2) then begin
         FDDSImage2._Release;
         FDDSImage2 := nil;
      end;
      if Assigned(FDDSImage1) then begin
         FDDSImage1._Release;
         FDDSImage1 := nil;
      end;
      if Assigned(FDDSPrimary) then begin
         FDDSPrimary._Release;
         FDDSPrimary := nil;
      end;
      FDD._Release;  
      FDD := nil;
  end;
  if Assigned (wrkBitmap) then wrkBitmap.Free;
end;

procedure TfrmDD.ApplicationEvents1Deactivate(Sender: TObject);
begin
  FActive := False;
  Application.Minimize;
end;

procedure TfrmDD.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (Key = VK_ESCAPE) or (Key = VK_F12) then begin
     Close;
     Exit;
  end else
  if Key = VK_LEFT then StepX := StepX + 1 else
  if Key = VK_RIGHT then StepX := StepX - 1 else
  if Key = VK_UP then StepY := StepY + 1 else
  if Key = VK_DOWN then StepY := StepY - 1;

  if StepY < 1 then StepY := 1 else
  if StepY > 3 then StepY := 3;

  if StepX < -4 then StepX := -4 else
  if StepX > 4 then StepX := 4;

  with RotateBmp (wrkBitmap, 170, 135, arctan (StepX / StepY)) do begin
       DDCopyBitmap (FDDSFighter, Handle, 0, 0, Width, Height);
       Free
  end;
end;

procedure TfrmDD.FormSetCursor(var aMsg : TMessage);
begin
  SetCursor(0);
end;

function TfrmDD.RestoreAll : HRESULT;
var
  hRet : HRESULT;
begin
  hRet := FDDSPrimary._Restore;
  if Succeeded (hRet) then begin
      hRet := FDDSFighter._Restore;
      if Failed (hRet) then begin
         Result := hRet;
         Exit;
      end;
      with RotateBmp (wrkBitmap, 170, 135, arctan (StepX / StepY)) do begin
           hRet := DDCopyBitmap (FDDSFighter, Handle, 0, 0, Width, Height);
           Free
      end;
      if Failed (hRet)
         then ErrorOut(hRet, 'DDCopyBitmap');
      hRet := FDDSImage3._Restore;
      if Failed (hRet) then begin
         Result := hRet;
         Exit;
      end;
      hRet := DDReLoadBitmap(FDDSImage3, starBmp3);
      if Failed (hRet) then ErrorOut(hRet, 'DDReLoadBitmap');
      hRet := FDDSImage2._Restore;
      if Failed (hRet) then begin
         Result := hRet;
         Exit;
      end;
      hRet := DDReLoadBitmap(FDDSImage2, starBmp2);
      if Failed (hRet) then ErrorOut(hRet, 'DDReLoadBitmap');
      hRet := FDDSImage1._Restore;
      if Failed (hRet) then begin
         Result := hRet;
         Exit;
      end;
      hRet := DDReLoadBitmap(FDDSImage1, starBmp1);
      if Failed (hRet)
         then ErrorOut(hRet, 'DDReLoadBitmap');
      Result := DD_OK
  end else Result := hRet;
end;

procedure TfrmDD.ApplicationEvents1Restore(Sender: TObject);
begin
  WindowState := wsMaximized;
  FActive := True;
end;

procedure TfrmDD.FormActivate(Sender: TObject);
begin
  LastTickCount := GetTickCount;
  FActive := True;
end;

procedure TfrmDD.ApplicationEvents1Idle(Sender: TObject;
  var Done: Boolean);
begin
  if FActive then begin
     UpdateFrame;
     FlipPages;
  end;
  Done := False;
end;

function TfrmDD.Clear : HRESULT;
var
  ddbltfx : TDDBLTFX;
begin
  ZeroMemory(@ddbltfx, SizeOf(ddbltfx));
  ddbltfx.dwSize := SizeOf(ddbltfx);
  ddbltfx.dwFillColor := 0;
  Result := FDDSBack.Blt(nil, nil, nil, DDBLT_COLORFILL or DDBLT_WAIT, @ddbltfx);
end;

function TfrmDD.UpdateFrame : HRESULT;
var
  i : Integer;
begin
  ThisTickCount := GetTickCount;

  if ThisTickCount - LastTickCount > 5 then begin

     for i := 0 to NumStars - 1 do begin
         Stars1 [i].X := (Stars1 [i].X + StepX);
         if Stars1 [i].X > ScreenWidth - 2
            then Stars1 [i].X := 0 else
         if Stars1 [i].X < 0
            then Stars1 [i].X := ScreenWidth - 2;

         Stars2 [i].X := (Stars2 [i].X + 2 * StepX);
         if Stars2 [i].X > ScreenWidth - 2
            then Stars2 [i].X := 0 else
         if Stars2 [i].X < 0
            then Stars2 [i].X := ScreenWidth - 2;

         Stars3 [i].X := (Stars3 [i].X + 3 * StepX);
         if Stars3 [i].X > ScreenWidth - 2
            then Stars3 [i].X := 0 else
         if Stars3 [i].X < 0
            then Stars3 [i].X := ScreenWidth - 2;

         Stars1 [i].Y := (Stars1 [i].Y + StepY);
         if Stars1 [i].Y > ScreenHeight - 2
            then Stars1 [i].Y := 0 else
         if Stars1 [i].Y < 0
            then Stars1 [i].Y := ScreenHeight - 2;

         Stars2 [i].Y := (Stars2 [i].Y + 2 * StepY);
         if Stars2 [i].Y > ScreenHeight - 2
            then Stars2 [i].Y := 0 else
         if Stars2 [i].Y < 0
            then Stars2 [i].Y := ScreenHeight - 2;

         Stars3 [i].Y := (Stars3 [i].Y + 3 * StepY);
         if Stars3 [i].Y > ScreenHeight - 2
            then Stars3 [i].Y := 0 else
         if Stars3 [i].Y < 0
            then Stars3 [i].Y := ScreenHeight - 2;

     end;

     LastTickCount := GetTickCount;
  end;

  Clear;

  for i := 0 to NumStars - 1 do begin
      FDDSBack.BltFast (Stars1 [i].X, Stars1 [i].Y,
                 FDDSImage1, nil, DDBLTFAST_WAIT);
      FDDSBack.BltFast (Stars2 [i].X, Stars2 [i].Y,
                 FDDSImage2, nil, DDBLTFAST_WAIT);
      FDDSBack.BltFast (Stars3 [i].X, Stars3 [i].Y,
                 FDDSImage3, nil, DDBLTFAST_WAIT);
  end;

  Result := FDDSBack.BltFast (150, 140,
                    FDDSFighter, nil, DDBLTFAST_WAIT or DDBLTFAST_SRCCOLORKEY);
end;

function TfrmDD.FlipPages : HRESULT;
begin
  if Failed (FDDSPrimary.Flip(nil, DDFLIP_WAIT))
     then Result := RestoreAll
     else Result := DD_OK;
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
  Hide
end;

end.

