{******************************************************************************}
{* Иллюстрация к книге "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 FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
    FDD            : IDirectDraw7;
    FDDSPrimary    : IDirectDrawSurface7;
    FDDSBack       : IDirectDrawSurface7;
    FDDSMouse      : IDirectDrawSurface7;
    FDDSImageSphere: IDirectDrawSurface7;
    FDDSImageSelect: IDirectDrawSurface7;
    FDDSImageRed   : IDirectDrawSurface7;
    FDDSImageGreen : IDirectDrawSurface7;
    FDDSImageBlue  : IDirectDrawSurface7;
    FDDSDouble     : IDirectDrawSurface7;
    FActive        : BOOL;
    ThisTickCount  : DWORD;
    LastTickCount  : DWORD;
    function UpdateFrame : HRESULT;
    function RestoreAll : HRESULT;
    function FlipPages : HRESULT;
    procedure ErrorOut(hRet : HRESULT; FuncName : String);
    function Select (const X, Y : Integer) : Integer;
  public
    { Public declarations }
  protected
    procedure FormSetCursor(var aMsg : TMessage); message WM_SETCURSOR;
  end;

const
  ScreenWidth    = 640;
  ScreenHeight   = 480;
  ScreenBitDepth = 16;
  imageBmp1       = '..\RedSphere.bmp';
  imageBmp2       = '..\SelectSphere.bmp';
  imageMouse      = '..\3DArrow.bmp';
  imageRed        = '..\spRed.bmp';
  imageGreen      = '..\spGreen.bmp';
  imageBlue       = '..\spBlue.bmp';

var
  frmDD : TfrmDD;
  mouseX : Integer = 0;
  mouseY : Integer = 0;
  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;
  ddscaps : TDDSCaps2;
begin
  FDDSDouble := nil;
  FDDSMouse := nil;
  FDDSImageSelect := nil;
  FDDSImageSphere := 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');

  FDDSImageSphere := DDLoadBitmap(FDD, imageBmp1, 0, 0);
  if FDDSImageSphere = nil then ErrorOut(DD_FALSE, 'DDLoadBitmap');

  FDDSImageSelect := DDLoadBitmap(FDD, imageBmp2, 0, 0);
  if FDDSImageSelect = nil then ErrorOut(DD_FALSE, 'DDLoadBitmap');

  FDDSImageRed := DDLoadBitmap(FDD, imageRed, 0, 0);
  if FDDSImageRed = nil then ErrorOut(DD_FALSE, 'DDLoadBitmap');

  FDDSImageGreen := DDLoadBitmap(FDD, imageGreen, 0, 0);
  if FDDSImageGreen = nil then ErrorOut(DD_FALSE, 'DDLoadBitmap');

  FDDSImageBlue := DDLoadBitmap(FDD, imageBlue, 0, 0);
  if FDDSImageBlue = nil then ErrorOut(DD_FALSE, 'DDLoadBitmap');

  FDDSMouse := DDLoadBitmap(FDD, imageMouse, 0, 0);
  if FDDSMouse = nil then ErrorOut(DD_FALSE, 'DDLoadBitmap');

  hRet := DDSetColorKey (FDDSMouse, RGB (255, 255, 255));
  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;
     ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN ;
     dwHeight := ScreenHeight;
     dwWidth := ScreenWidth;
  end;
  hRet := FDD.CreateSurface(ddsd, FDDSDouble, nil);
  if Failed(hRet) then ErrorOut(hRet, 'Create Double Surface');
end;

procedure TfrmDD.FormDestroy(Sender: TObject);
begin
  if Assigned(FDD) then begin
      if Assigned(FDDSDouble) then FDDSMouse := nil;
      if Assigned(FDDSMouse) then FDDSMouse := nil;
      if Assigned(FDDSImageBlue) then FDDSImageBlue := nil;
      if Assigned(FDDSImageGreen) then FDDSImageGreen := nil;
      if Assigned(FDDSImageRed) then FDDSImageRed := nil;
      if Assigned(FDDSImageSelect) then FDDSImageSelect := nil;
      if Assigned(FDDSImageSphere) then FDDSImageSphere := nil;
      if Assigned(FDDSBack) then FDDSBack := nil;
      if Assigned(FDDSPrimary) then FDDSPrimary := nil;
      FDD := nil;
  end;
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 Close;
end;

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

function TfrmDD.RestoreAll : HRESULT;
var
  hRet : HRESULT;
begin
  hRet := FDDSPrimary._Restore;
  Result := hRet;
  if Succeeded (hRet) then begin
      if Failed (FDDSDouble._Restore) then Exit;
      if Failed (FDDSMouse._Restore) then Exit;
      if Failed (DDReLoadBitmap (FDDSMouse, imageMouse))
         then ErrorOut(DD_FALSE, 'DDReLoadBitmap');
      if Failed (FDDSImageBlue._Restore) then Exit;
      if Failed (DDReLoadBitmap (FDDSImageBlue, imageBlue))
         then ErrorOut(DD_FALSE, 'DDReLoadBitmap');
      if Failed (FDDSImageGreen._Restore) then Exit;
      if Failed (DDReLoadBitmap (FDDSImageGreen, imageGreen))
         then ErrorOut(DD_FALSE, 'DDReLoadBitmap');
      if Failed (FDDSImageRed._Restore) then Exit;
      if Failed (DDReLoadBitmap (FDDSImageRed, imageRed))
         then ErrorOut(DD_FALSE, 'DDReLoadBitmap');
      if Failed (FDDSImageSelect._Restore) then Exit;
      if Failed (DDReLoadBitmap (FDDSImageSelect, imageBmp2))
         then ErrorOut(DD_FALSE, 'DDReLoadBitmap');
      if Failed (FDDSImageSphere._Restore) then Exit;
      if Failed (DDReLoadBitmap (FDDSImageSphere, imageBmp1))
         then ErrorOut(DD_FALSE, 'DDReLoadBitmap');      
      Result := DD_OK;
  end;
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 UpdateFrame;
  Done := False;
end;

function TfrmDD.UpdateFrame : HRESULT;
var
  ddbltfx : TDDBLTFX;
  wrkI : Integer;
begin
  ZeroMemory (@ddbltfx, SizeOf(ddbltfx));
  ddbltfx.dwSize := SizeOf(ddbltfx);
  ddbltfx.dwFillColor := 0;
  FDDSBack.Blt(nil, nil, nil, DDBLT_COLORFILL or DDBLT_WAIT, @ddbltfx);
  FDDSDouble.Blt(nil, nil, nil, DDBLT_COLORFILL or DDBLT_WAIT, @ddbltfx);

  ThisTickCount := GetTickCount;

  if ThisTickCount - LastTickCount > 10 then begin
     Angle := Angle + 0.02;
     if Angle > 2 * Pi then Angle := Angle - 2 * Pi;

     LastTickCount := GetTickCount;
  end;

  FDDSDouble.BltFast (0, 140 - trunc (sin (Angle) * 100), FDDSImageRed, nil, DDBLTFAST_WAIT);
  FDDSDouble.BltFast (230, 140 - trunc (sin (Angle + Pi / 4) * 100), FDDSImageGreen, nil, DDBLTFAST_WAIT);
  FDDSDouble.BltFast (440, 140 - trunc (sin (Angle + Pi / 2) * 100), FDDSImageBlue, nil, DDBLTFAST_WAIT);

  wrkI := Select (mouseX, mouseY);
  if wrkI = -1 then begin
     Result := RestoreAll;
     Exit;
  end;

  if wrkI = 1
     then FDDSBack.BltFast (0, 140 - trunc (sin (Angle) * 100), FDDSImageSelect, nil, DDBLTFAST_WAIT)
     else FDDSBack.BltFast (0, 140 - trunc (sin (Angle) * 100), FDDSImageSphere, nil, DDBLTFAST_WAIT);

  if wrkI = 2
     then FDDSBack.BltFast (220, 140 - trunc (sin (Angle + Pi / 4) * 100), FDDSImageSelect, nil, DDBLTFAST_WAIT)
     else FDDSBack.BltFast (220, 140 - trunc (sin (Angle + Pi / 4) * 100), FDDSImageSphere, nil, DDBLTFAST_WAIT);

  if wrkI = 3
     then FDDSBack.BltFast (440, 140 - trunc (sin (Angle + Pi / 2) * 100), FDDSImageSelect, nil, DDBLTFAST_WAIT)
     else FDDSBack.BltFast (440, 140 - trunc (sin (Angle + Pi / 2) * 100), FDDSImageSphere, nil, DDBLTFAST_WAIT);

  FDDSBack.BltFast (mouseX, mouseY, FDDSMouse, nil,
                    DDBLTFAST_WAIT or DDBLTFAST_SRCCOLORKEY);

  if Failed (FlipPages)
     then Result := RestoreAll
     else Result := DD_OK;
end;

function TfrmDD.FlipPages : HRESULT;
begin
  Result := FDDSPrimary.Flip(nil, DDFLIP_WAIT);
end;

procedure TfrmDD.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if X <= ScreenWidth - 60
     then mouseX := X
     else mouseX := ScreenWidth - 60;
  if Y <= ScreenHeight - 60
     then mouseY := Y
     else mouseY := ScreenHeight - 60;
end;

function TfrmDD.Select (const X, Y : Integer) : Integer;
var
   desc : TDDSURFACEDESC2;
   Red, Green, Blue : Byte;
   Pixel : Word;
begin
   Result := -1;

   ZeroMemory (@desc, SizeOf(desc));
   desc.dwSize := SizeOf(desc);

   if Failed (FDDSDouble.Lock (nil, desc, DDLOCK_WAIT, 0)) then Exit;

   Pixel := PWord (Integer (desc.lpSurface) + Y * desc.lPitch + X * 2)^;

   Blue := Pixel and $1F;
   Green := (Pixel shr 5) and $3F;
   Red := (Pixel shr 11) and $1F;

   FDDSDouble.Unlock (nil);

   if Blue <> 0 then Result := 3 else
   if Green <> 0 then Result := 2 else
   if Red <> 0 then Result := 1 else Result := 0;
end;

procedure TfrmDD.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Hide
end;

end.


