{******************************************************************************}
{* Иллюстрация к книге "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, DirectInput8;

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 FormClose(Sender: TObject; var Action: TCloseAction);
    procedure ApplicationEvents1Idle(Sender: TObject; var Done: Boolean);
    procedure FormActivate(Sender: TObject);
  private
    { Private declarations }
    FDD            : IDirectDraw7;
    FDDSPrimary    : IDirectDrawSurface7;
    FDDSBack       : IDirectDrawSurface7;
    FActive        : BOOL;
    FDDSBackGround : IDirectDrawSurface7;
    function UpdateFrame : HRESULT;
    function RestoreAll : HRESULT;
    function FlipPages : HRESULT;
    function Zoom : HRESULT;
    function OnCreateDevice : HRESULT;
    function ReadImmediateData : HRESULT;
    procedure ErrorOut(hRet : HRESULT; FuncName : String);
  public
    { Public declarations }
  protected
    procedure FormSetCursor(var aMsg : TMessage); message WM_SETCURSOR;
  end;

const
  ScreenWidth    = 800;
  ScreenHeight   = 600;
  ScreenBitDepth = 16;
  GroundBmp      = '..\beardo_pond1.bmp';
  Diameter	 = 180;
  Scale		 = 35;

var
  frmDD : TfrmDD;
  mouseX : Integer = 300;
  mouseY : Integer = 300;
  DInput : IDIRECTINPUT8 = nil;
  DIMouse : IDIRECTINPUTDEVICE8 = nil;
  Radius  : Integer = Diameter div 2;
  SqrRad  : Integer;
  Sphere  : Integer;

implementation

{$R *.DFM}

function TfrmDD.OnCreateDevice : HRESULT;
var
  hRet : HRESULT;
begin
  hRet := DirectInput8Create (hInstance, DIRECTINPUT_VERSION,
                                         IID_IDirectInput8, DInput, nil);
  if Failed (hRet) then begin
     Result := hRet;
     Exit
  end;

  hRet := DInput.CreateDevice (GUID_SysMouse, DIMouse, nil);
  if Failed (hRet) then begin
     Result := hRet;
     Exit
  end;

  hRet := DIMouse.SetDataFormat(c_dfDIMouse2);
  if Failed (hRet) then begin
     Result := hRet;
     Exit
  end;

  hRet := DIMouse.SetCooperativeLevel(Handle, DISCL_NONEXCLUSIVE or DISCL_BACKGROUND);
  if Failed (hRet) then begin
     Result := hRet;
     Exit
  end;

  Result := DIMouse.Acquire;
end;

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
  FDDSBackGround := 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');

  FillChar (ddsd, SizeOf(ddsd), 0);
  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');

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

  FDDSBackGround := DDLoadBitmap(FDD, GroundBmp, 0, 0);
  if FDDSBackGround = nil then ErrorOut(DD_FALSE, 'DDLoadBitmap');

  if Failed (OnCreateDevice) then ErrorOut(DD_FALSE, 'CreateDevice');

  SqrRad  := Radius * Radius;
  Sphere  := (Radius * Radius) - (Scale * Scale);
end;

procedure TfrmDD.FormDestroy(Sender: TObject);
begin
  if Assigned(FDD) then begin
      if Assigned(FDDSBackGround) then FDDSBackGround := nil;
      if Assigned(FDDSBack) then FDDSBack := nil;
      if Assigned(FDDSPrimary) then FDDSPrimary := nil;
      FDD._Release;
      FDD := nil;
  end;
  if Assigned (DIMouse) then DIMouse.Unacquire;
  if Assigned (DIMouse) then DIMouse := nil;
  if Assigned (DInput) then DInput := nil;
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;
  if Succeeded (hRet) then begin
      hRet := FDDSBackGround._Restore;
      if Failed (hRet) then begin
         Result := hRet;
         Exit;
      end;
      if Failed (DDReLoadBitmap(FDDSBackGround, GroundBmp))
         then ErrorOut(DD_FALSE, 'DDReLoadBitmap');
      Result := DD_OK;
  end
  else Result := DD_OK;
end;

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

function TfrmDD.UpdateFrame : HRESULT;
var
  hRet : HRESULT;
begin
  hRet := FDDSBack.BltFast (0, 0, FDDSBackGround, nil, DDBLTFAST_WAIT);
  if Failed (hRet) then begin
     Result := hRet;
     Exit;
  end;

  hRet := Zoom;
  if Failed (hRet) then begin
     Result := hRet;
     Exit;
  end;

  Result := FlipPages;
end;

function TfrmDD.FlipPages : HRESULT;
begin
  if FDDSPrimary.Flip(nil, DDFLIP_WAIT) = DDERR_SURFACELOST
     then Result := RestoreAll
     else Result := DD_OK;
end;

function TfrmDD.Zoom : HRESULT;
var
  desc1 : TDDSURFACEDESC2;
  desc2 : TDDSURFACEDESC2;
  X, Y : Integer;
  XX,YY,YYXX : Integer;
  mz : Single;
  hRet : HRESULT;
begin
  ZeroMemory (@desc1, SizeOf(desc1));
  desc1.dwSize := SizeOf (desc1);

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

  hRet := FDDSBack.Lock (nil, desc1, DDLOCK_WAIT, 0);
  if Failed (hRet) then begin
     Result := hRet;
     Exit;
  end;

  hRet := FDDSBackGround.Lock (nil, desc2, DDLOCK_WAIT, 0);
  if Failed (hRet) then begin
     Result := hRet;
     Exit;
  end;

  for Y := -Radius to Radius do begin
      YY := Y * Y;
      for X := -Radius to Radius do begin
      XX := X * X;
      YYXX := YY + XX;
      if YYXX < Sphere then begin
       mz := Scale / sqrt(SqrRad-YYXX);
       PWord (Integer(desc1.lpSurface) + (Y + mouseY) * desc1.lPitch +
              (mouseX + x) * 2)^ :=
               PWord (Integer(desc2.lpSurface) +
                       trunc (mz * Y + mouseY) * desc2.lPitch +
                       trunc (mz * X + mouseX) * 2)^;
       end;
      end;
  end;

  FDDSBackGround.Unlock (nil);
  FDDSBack.Unlock (nil);

  Result := DD_OK;
end;

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

function TfrmDD.ReadImmediateData : HRESULT;
var
  hRet : HRESULT;
  dims2 : TDIMOUSESTATE2;
begin
  ZeroMemory(@dims2, SizeOf(dims2));
  hRet := DIMouse.GetDeviceState(SizeOf(TDIMOUSESTATE2), @dims2);
  if Failed (hRet) then begin
     hRet := DIMouse.Acquire;
     while hRet = DIERR_INPUTLOST do hRet := DIMouse.Acquire;
  end;

  if dims2.rgbButtons[0] = 128 then begin
     Radius := Radius + 1;
     if Radius > Diameter then Radius := Diameter;
     SqrRad  := Radius * Radius;
     Sphere  := (Radius * Radius) - (Scale * Scale);
  end;

  if dims2.rgbButtons[1] = 128 then begin
     Radius := Radius - 1;
     if Radius < 0 then Radius := 0;
     SqrRad  := Radius * Radius;
     Sphere  := (Radius * Radius) - (Scale * Scale);
  end;

  mouseX := mouseX + 2 * dims2.lX;
  if mouseX < Radius then mouseX := Radius else
  if mouseX > ScreenWidth - Radius then mouseX := ScreenWidth - Radius;

  mouseY := mouseY + 2 * dims2.lY;
  if mouseY < Radius then mouseY := Radius else
  if mouseY > ScreenHeight - Radius then mouseY := ScreenHeight - Radius;

  Result := DI_OK;
end;

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

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

end.


