{******************************************************************************}
{* Иллюстрация к книге "DirectX. Графика в проектах Delphi".                  *}
{* Издательство BHV. www.bhv.ru                                               *}
{* Краснов М.В. softgl@chat.ru                                                *}
{******************************************************************************}
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  AppEvnts,
  DirectXGraphics;

type
  TfrmD3D = class(TForm)
    ApplicationEvents1: TApplicationEvents;
    procedure FormCreate(Sender: TObject);
    procedure ApplicationEvents1Minimize(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure ApplicationEvents1Idle(Sender: TObject; var Done: Boolean);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure ApplicationEvents1Restore(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    FD3D            : IDIRECT3D8;
    FD3DDevice      : IDIRECT3DDEVICE8;
    FD3DVB          : IDIRECT3DVERTEXBUFFER8;
    FActive         : BOOL;
    ThisTickCount   : DWORD;
    LastTickCount   : DWORD;
    function Render : HRESULT;
    function InitD3D : HRESULT;
    function InitPoints : HRESULT;
    procedure Cleanup;
    procedure ErrorOut (const Caption : PChar; const hError : HRESULT);
    function DrawPix(const inX, inY : Integer) : HRESULT;
    procedure DrawFire;
  public
    { Public declarations }
  end;

type
  TCUSTOMVERTEX = packed record
    X, Y, Z, RHW : Single;
    Color : DWORD;
  end;

type
  TRGB = packed record
     R, G, B : BYTE;
  end;

const
  Size = 2;
  Fade = 4;
  NumX = 150;
  NumY = 150;

var
  Fire : Array [1..NumX, 1..NumY + 1] of TRGB;
  PreF : Array [1..NumX] of TRGB;
  Angle : Single = 0.0;
  ParticleX : Integer = 0;
  ParticleY : Integer = NumY;

const
  D3DFVF_CUSTOMVERTEX = D3DFVF_XYZRHW or D3DFVF_DIFFUSE;

var
  frmD3D: TfrmD3D;
  Frames : Integer = 0;

  VPoints : Array [0..3] of TCUSTOMVERTEX;

implementation

{$R *.DFM}

function TfrmD3D.DrawPix(const inX, inY : Integer) : HRESULT;
var
  pVertices : PByte;
  hRet : HRESULT;
begin
  with VPoints [0] do begin
    X := inX * Size;
    Y := 300 - inY * Size;
    Color := D3DCOLOR_XRGB(Fire[inX, inY + 1].R, Fire[inX, inY + 1].G, Fire[inX, inY + 1].B);
  end;

  with VPoints [1] do begin
    X := inX * Size;
    Y := 300 - (inY + 1) * Size;
    Color := D3DCOLOR_XRGB(Fire[inX, inY].R, Fire[inX, inY].G, Fire[inX, inY].B);
  end;

  with VPoints [2] do begin
    X := (inX + 1) * Size;
    Y := 300 - inY * Size;
    Color := D3DCOLOR_XRGB(Fire[inX + 1, inY + 1].R, Fire[inX + 1, inY + 1].G, Fire[inX + 1, inY + 1].B);
  end;

  with VPoints [3] do begin
    X := (inX + 1) * Size;
    Y := 300 - (inY + 1) * Size;
    Color := D3DCOLOR_XRGB(Fire[inX + 1, inY].R, Fire[inX + 1, inY].G, Fire[inX + 1, inY].B);
  end;

  hRet := FD3DVB.Lock(0, SizeOf(VPoints), pVertices, 0);
  if Failed (hRet) then begin
     Result := hRet;
     Exit;
  end;

  Move (VPoints, pVertices^, SizeOf(VPoints));

  hRet := FD3DVB.Unlock;
  if FAILED(hRet) then begin
     Result := hRet;
     Exit;
  end;

  Result := FD3DDevice.DrawPrimitive(D3DPT_TRIANGLESTRIP, 0, 2);
end;

procedure TfrmD3D.DrawFire;
var
  i, j : Integer;
  f : Byte;
begin
  for i := 2 to NumX-1 do begin
      f := random(255);
      PreF[i].R := 255;
      PreF[i].G := trunc (f / 1.4);
      PreF[i].B := f div 2;
  end;

  for i := 2 to NumX - 1 do begin
      Fire[i, 1].R := (PreF[i - 1].R + PreF[i + 1].R + PreF[i].R) div 3;
      Fire[i, 1].G := (PreF[i - 1].G + PreF[i + 1].G + PreF[i].G) div 3;
      Fire[i, 1].B := (PreF[i - 1].B + PreF[i + 1].B + PreF[i].B) div 3;
  end;
  for j := NumY - 1 downto 2 do
  for i := 2 to NumX - 1 do begin
      Fire[i,j].R := (Fire[i-1, j].R   + Fire[i+1, j].R + Fire[i,j].R +
                     Fire[i-1, j-1].R + Fire[i+1, j-1].R + Fire[i, j-1].R
                     ) div 6;
      Fire[i,j].G := (Fire[i-1, j].G   + Fire[i+1, j].G + Fire[i,j].G +
                     Fire[i-1, j-1].G + Fire[i+1, j-1].G + Fire[i, j-1].G
                     ) div 6;
      Fire[i,j].B := (Fire[i-1, j].B   + Fire[i+1, j].B + Fire[i,j].B +
                     Fire[i-1, j-1].B + Fire[i+1, j-1].B + Fire[i, j-1].B
                     ) div 6;
  end;

  for j := ParticleY - 1 to ParticleY  do
     for i := ParticleX - 1 to ParticleX  do begin
         Fire[i, j].R := 255;
         Fire[i, j].G := 0;
         Fire[i, j].B := 0;
  end;

  for j := 2 to NumY - 1 do
    for i := 2 to NumX - 1 do
      DrawPix (i - 1, j - 1);

  for j := NumY downto 2 do
    for i := 1 to NumX do begin
      if Fire[i, j - 1].R >= Fade
         then Fire[i, j].R := Fire[i, j - 1].R - Fade
         else Fire[i, j].R := 0;
      if Fire[i, j - 1].G >= Fade
         then Fire[i, j].G := Fire[i, j - 1].G - Fade
         else Fire[i, j].G := 0;
      if Fire[i, j - 1].B >= Fade
         then Fire[i, j].B := Fire[i, j - 1].B - Fade
         else Fire[i, j].B := 0;
  end;
end;

procedure TfrmD3D.Cleanup;
begin
  if Assigned (FD3DVB) then begin
     FD3DVB._Release;
     FD3DVB := nil;
  end;

  if Assigned (FD3DDevice) then begin
     FD3DDevice._Release;
     FD3DDevice := nil;
  end;

  if Assigned (FD3D) then begin
     FD3D._Release;
     FD3D := nil;
  end;
end;

procedure TfrmD3D.ErrorOut (const Caption : PChar; const hError : HRESULT);
begin
  FActive := False;
  Cleanup;
  MessageBox (Handle, PChar(DXGErrorString (hError)), Caption, 0);
end;

function TfrmD3D.InitD3D : HRESULT;
var
  d3ddm : TD3DDISPLAYMODE;
  d3dpp : TD3DPRESENT_PARAMETERS;
  hRet : HRESULT;
begin
  FD3DDevice := nil;
  FD3DVB := nil;
  FD3D := nil;

  FD3D := Direct3DCreate8(D3D_SDK_VERSION);
  if FD3D = nil then begin
     Result := E_FAIL;
     Exit;
  end;

  hRet := FD3D.GetAdapterDisplayMode(D3DADAPTER_DEFAULT, d3ddm);
  if FAILED(hRet) then begin
     Result := hRet;
     Exit;
  end;

  ZeroMemory(@d3dpp, SizeOf(d3dpp));
  with d3dpp do begin
       Windowed := True;
       SwapEffect := D3DSWAPEFFECT_DISCARD;
       BackBufferFormat := d3ddm.Format;
  end;

  Result := FD3D.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, Handle,
                              D3DCREATE_SOFTWARE_VERTEXPROCESSING,
                              d3dpp, FD3DDevice);
end;

function TfrmD3D.Render : HRESULT;
var
  hRet : HRESULT;
begin
  if FD3DDevice = nil then begin
     Result := E_FAIL;
     Exit;
  end;

  hRet := FD3DDevice.Clear(0, nil, D3DCLEAR_TARGET, 0, 0.0, 0);
  if FAILED(hRet) then begin
     Result := hRet;
     Exit;
  end;

  hRet := FD3DDevice.BeginScene;
  if FAILED(hRet) then begin
     Result := hRet;
     Exit;
  end;

  DrawFire;

  hRet := FD3DDevice.EndScene;
  if FAILED(hRet) then begin
     Result := hRet;
     Exit;
  end;

  Result := FD3DDevice.Present(nil, nil, 0, nil);
end;

procedure TfrmD3D.FormCreate(Sender: TObject);
var
  hRet : HRESULT;
begin
  hRet := InitD3D;
  if Failed (hRet) then ErrorOut ('InitD3D', hRet);
  hRet := InitPoints;
  if Failed (hRet) then ErrorOut ('InitPoint', hRet);
end;

procedure TfrmD3D.ApplicationEvents1Minimize(Sender: TObject);
begin
  FActive := False;
end;

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

procedure TfrmD3D.ApplicationEvents1Idle(Sender: TObject;
  var Done: Boolean);
var
  hRet : HRESULT;
begin
  if FActive then begin
     Inc (Frames);
     hRet := Render;
     if FAILED(hRet) then begin
        FActive := False;
        ErrorOut ('Render', hRet);
        Exit;
     end;

     ThisTickCount := GetTickCount;
     if ThisTickCount - LastTickCount > 50 then begin
        Caption := 'FPS = ' + Format('%6.2f',
                                 [frames * 1000 / (ThisTickCount - LastTickCount)]);
        Frames := 0;

        ParticleX := trunc (150 - sin (Angle) * 80) div Size;
        ParticleY := ParticleY - 1;

        if ParticleY < 0 then ParticleY := ParticleY;

        Angle := Angle + 0.05;
        if Angle > 2 * Pi then Angle := Angle - 2 * Pi;

        LastTickCount := GetTickCount;
     end;
  end;

  Done := False;
end;

procedure TfrmD3D.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key = VK_ESCAPE then Close;
end;

procedure TfrmD3D.ApplicationEvents1Restore(Sender: TObject);
begin
  FActive := True;
end;

procedure TfrmD3D.FormDestroy(Sender: TObject);
begin
  Cleanup
end;

function TfrmD3D.InitPoints : HRESULT;
var
  pVertices : PByte;
  hRet : HRESULT;
  i : Integer;
begin
  for i := 0 to 3 do
      with VPoints [i] do begin
           Z := 0.0;
           RHW := 0.0;
  end;

  hRet := FD3DDevice.CreateVertexBuffer(SizeOf(VPoints),
                                        D3DUSAGE_WRITEONLY, D3DFVF_CUSTOMVERTEX,
                                        D3DPOOL_DEFAULT, FD3DVB);
  if Failed (hRet) then begin
     Result := hRet;
     Exit;
  end;

  hRet := FD3DVB.Lock(0, SizeOf(VPoints), pVertices, 0);
  if Failed (hRet) then begin
     Result := hRet;
     Exit;
  end;

  Move (VPoints, pVertices^, SizeOf(VPoints));

  hRet := FD3DVB.Unlock;
  if Failed (hRet) then begin
     Result := hRet;
     Exit;
  end;

  hRet := FD3DDevice.SetStreamSource(0, FD3DVB, SizeOf(TCUSTOMVERTEX));
  if Failed (hRet) then begin
     Result := hRet;
     Exit;
  end;

  Result := FD3DDevice.SetVertexShader(D3DFVF_CUSTOMVERTEX);
end;


end.
