{******************************************************************************}
{* Иллюстрация к книге "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;
    FDDSPrimary    : IDirectDrawSurface7;
    FActive        : BOOL;
    function UpdateFrame : HRESULT;
    function FlipPages : HRESULT;
    function RestoreAll : 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 = 16;

  MAX_ENERGY = 60;
  DEFAULT_SIZE = 200;
  DEFAULT_POWER = 30;

type
  TParticle = record
	X, Y : Single;
	SpeedX, SpeedY : Single;
	Energy : Integer;
	Angle : Integer;
        R, G, B : Byte;
  end;

  TParticleSystem = class
     public
        procedure Init (NewSize, Power : Integer);
	procedure Calculate;
	function Render : HRESULT;
     private
	Particle : Array [0..1000] of TParticle;
	Size : integer;
  end;

var
  frmDD : TfrmDD;

  sinA : Array [0..360] of Single;
  cosA : Array [0..360] of Single;

  PS : TParticleSystem;
  Time : integer = 0;

implementation

{$R *.DFM}

procedure TParticleSystem.Init (NewSize, Power : Integer);
var
  i : Integer;
  X, Y : Integer;
  Speed : Single;
begin
  Size := NewSize;

  X := random (ScreenWidth - 80) + 40;
  Y := random (ScreenHeight - 80) + 40;

  for i := 0 to Size do begin
  	Particle[i].X	    := X;
  	Particle[i].Y	    := Y;
  	Particle[i].Energy  := random (MAX_ENERGY);
  	Particle[i].Angle   := random (360);
  	Speed		    := random (Power) - Power / 2;
  	Particle[i].SpeedX  := sinA[Particle[i].Angle] * Speed;
  	Particle[i].SpeedY  := cosA[Particle[i].Angle] * Speed;
  	Particle[i].r	    := random (256);
  	Particle[i].g	    := 0;
  	Particle[i].b	    := random (256);
  end;
end;

procedure TParticleSystem.Calculate;
var
  i : Integer;
begin
  for i := 0 to Size do begin
      if Particle[i].Energy > 0 then begin
         Particle[i].X := Particle [i].X + Particle [i].SpeedX;
	 if Particle[i].X >= ScreenWidth - 1 then begin
            Particle[i].SpeedX := -0.5 * Particle [i].SpeedX;
            Particle[i].X := ScreenWidth - 1;
         end;
	 if Particle[i].X < 0 then begin
            Particle[i].SpeedX := -0.5 * Particle [i].SpeedX;
            Particle[i].X := 0;
         end;
    	 Particle [i].Y := Particle[i].Y + Particle[i].SpeedY;
	 if Particle[i].Y >= ScreenHeight - 1 then begin
            Particle[i].SpeedY := -0.3 * Particle[i].SpeedY;
            Particle[i].Y := ScreenHeight - 1;
         end;
	 if Particle[i].Y < 0 then begin
            Particle[i].SpeedY := -Particle[i].SpeedY;
            Particle[i].Y := 0;
         end;
	 Particle[i].Energy := Particle[i].Energy - 1;
	 Particle[i].SpeedY := Particle[i].SpeedY + 0.2;
	 end;
	end;
end;

function TParticleSystem.Render : HRESULT;
var
   i : Integer;
   desc : TDDSURFACEDESC2;
   hRet : HRESULT;
begin
   ZeroMemory (@desc, SizeOf(desc));
   desc.dwSize := SizeOf(desc);

   hRet := frmDD.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));

   for i := 0 to Size do
       if (Particle[i].Energy > 0) then
           PWord (Integer(desc.lpSurface) +
                     trunc (Particle[i].Y) * desc.lPitch +
                     trunc (Particle[i].X) * (ScreenBitDepth div 8))^ :=
           Particle[i].B or (Particle[i].G shl 5) or (Particle[i].R shl 11);

  Result := frmDD.FDDSBack.Unlock(nil);
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;
  j : Integer;
begin
  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');

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

  Randomize;

  for j := 0 to 360 do begin
      sinA[j] := sin(j * Pi / 180);
      cosA[j] := cos(j * Pi / 180);
  end;

  PS := TParticleSystem.Create;
  PS.Init (DEFAULT_SIZE, DEFAULT_POWER);
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;
  PS.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 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
          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
        else RestoreALL;
  Done := False;
end;

function TfrmDD.UpdateFrame : HRESULT;
var
  hRet : HRESULT;
begin
  PS.Calculate;

  hRet := PS.Render;
  if Failed (hRet) then begin
     Result := hRet;
     Exit;
  end;

  Time := Time + 1;
  if Time > 15 then begin
     PS.Init(DEFAULT_SIZE, DEFAULT_POWER);
     Time := 0;
  end;

  Result := DD_OK;
end;

function TfrmDD.FlipPages : HRESULT;
begin
  Result := FDDSPrimary.Flip(nil, DDFLIP_WAIT);
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.

