{******************************************************************************}
{* Иллюстрация к книге "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;
    FDDSBack       : IDirectDrawSurface7;
    FDDSPrimary    : IDirectDrawSurface7;
    FActive        : BOOL;
    function UpdateFrame : HRESULT;
    function FlipPages : HRESULT;
    function RestoreAll : HRESULT;
    function PutArray : HRESULT;
    function Clear : HRESULT;
    procedure ErrorOut(hRet : HRESULT; FuncName : string);
  public
    { Public declarations }
  protected
    procedure FormSetCursor(var aMsg : TMessage); message WM_SETCURSOR;
  end;

const
  ScreenWidth    = 640;
  ScreenHeight   = 480;
  ScreenBitDepth = 8;

var
  frmDD : TfrmDD;

implementation

{$R *.DFM}

const
  MaxParticles = 100000;

type
  TParticle = record
    X : Integer;
    Y : Integer;
    Angle : Single;
    Speed : Integer;
    Decay : Single;
    HalfLife : Single;
    AngleAdjustment : Single;
  end;

var
  ParticleCount : Integer = 10000;
  Particle : Array [0..MaxParticles] of TParticle;
  mouseX, mouseY : Integer;
  Pict : Array [0..ScreenWidth - 1, 0..ScreenHeight - 1] of Byte;
  BlurFactor : Integer = 1;

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;
  
function TfrmDD.PutArray : HRESULT;
var
  X : 0..ScreenWidth - 1;
  Y : 0..ScreenHeight - 1;
  desc : TDDSURFACEDESC2;
  hRet : HRESULT;
begin
  FillChar(desc, SizeOf(desc),0);
  desc.dwSize := SizeOf(desc);

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

  for X := 0 to ScreenWidth - 1 do
  for Y := 0 to ScreenHeight - 1 do
      PByte (Integer(desc.lpSurface) + Y * desc.lPitch +
             X * (ScreenBitDepth div 8))^ := Pict [X, Y];

  Result := FDDSBack.Unlock(nil);
end;

procedure TfrmDD.FormCreate(Sender: TObject);
var
  hRet : HRESULT;
  ddsd : TDDSurfaceDesc2;
  ddscaps : TDDSCaps2;
  Index : 0..MaxParticles;
begin
  FDDSBack := nil;
  FDDSPrimary := nil;
  FDD := nil;

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

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

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

  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 begin
     ErrorOut(hRet, 'Create Primary Surface');
     Exit;
  end;

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

  if Failed (Clear) then Close;
  FlipPages;
  if Failed (Clear) then Close;

  Randomize;

  for Index := 0 to MaxParticles do
        with Particle [Index] do begin
            Speed := 1 + round (random (3));
            Angle := random * 2 * Pi;
            X := random (ScreenWidth - 1) + 1;
            Y := random (ScreenHeight - 1) + 1;
            Decay := random;
            HalfLife := random / 20;
            AngleAdjustment := random / 20;
  end;
end;

procedure TfrmDD.FormDestroy(Sender: TObject);
begin
  if Assigned(FDD) then begin
      if Assigned(FDDSBack) then FDDSBack := nil;
      if Assigned(FDDSPrimary) then begin
         FDDSPrimary._Release;
         FDDSPrimary := nil;
      end;
      FDD._Release;
      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
  case Key of
     VK_NEXT : BlurFactor := BlurFactor + 1;
     VK_PRIOR : begin
                BlurFactor := BlurFactor - 1;
                if BlurFactor < 1 then BlurFactor := 1;
                end;
     VK_HOME : begin
               Inc (ParticleCount, 1000);
               if ParticleCount > MaxParticles then ParticleCount := MaxParticles;
               end;
     VK_END  : begin
               Dec (ParticleCount, 1000);
               if ParticleCount < 2000 then ParticleCount := 2000;
               end;
     VK_ESCAPE, VK_F12 : Close;
  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
          if Failed (Clear) then Close;
          if Failed (FlipPages) then Close;
          if Failed (Clear) then Close;
          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
  FActive := True;
end;

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

function TfrmDD.UpdateFrame : HRESULT;
var
  Index : 0..MaxParticles;
  X : 0..ScreenWidth - 1;
  Y : 0..ScreenHeight - 1;
  Accum : Integer;  
begin
  for Index := 0 to ParticleCount do
      with Particle [Index] do begin
                Decay := Decay - HalfLife;
                if Decay <= 0 then begin
                   Decay := 1;
                   X := mouseX;
                   Y := mouseY;
                end;
                Angle := Angle + AngleAdjustment;
                If Angle >= 2 * Pi then Angle := 0;
                X := X + round (cos(Angle) * Speed);
                Y := Y + round (sin(Angle) * Speed);
                If (X > ScreenWidth - 2) or (X < 2) then begin
                    X := mouseX;
                    Y := mouseY;
                    Angle := random * 2 * Pi;
                end
                else if (Y > ScreenHeight - 2) or (Y < 2) then begin
                    X := mouseX;
                    Y := mouseY;
                    Angle := random * 2 * Pi;
                end;
                Pict [X, Y] := Speed * 16 + 186;
  end;

  for Index := 1 to BlurFactor do
      for X := 2 to ScreenWidth - 2 do
         for Y := 2 to (ScreenHeight - 2) do begin
              Accum := 0;
              Accum := Accum + Pict [X, Y]
                  + Pict[X, Y + 1]
                  + Pict[X, Y - 1]
                  + Pict[X + 1, Y]
                  + Pict[X - 1, Y]
                  + Pict[X + 1, Y + 1]
                  + Pict[X - 1, Y - 1]
                  + Pict[X + 1, Y - 1]
                  + Pict[X - 1, Y + 1];

              Accum := Accum div 9;
              Pict [X, Y] := Accum;
  end;

  for Index := 0 to ScreenWidth - 1 do begin
      Pict[Index, 0] := 127;
      Pict[Index, ScreenHeight - 1] := 127;
      Pict[Index, 1] := 127;
      Pict[Index, ScreenHeight - 2] := 127;
  end;
  for Index := 0 to ScreenHeight - 1 do begin
      Pict[0, Index] := 127;
      Pict[ScreenWidth - 1, Index] := 127;
      Pict[1, Index] := 127;
      Pict[ScreenWidth - 2, Index] := 127;
  end;

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

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

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

function TfrmDD.Clear : HRESULT;
var
   desc : TDDSURFACEDESC2;
   hRet : HRESULT;
begin
   ZeroMemory (@desc, SizeOf(desc));
   desc.dwSize := SizeOf(desc);

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

   ZeroMemory (desc.lpSurface, desc.lPitch * ScreenHeight * (ScreenBitDepth div 8));

   Result := FDDSBack.Unlock (nil);
end;

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

end.

