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

interface

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

type
  TfrmD3D = class(TForm)
    ApplicationEvents1: TApplicationEvents;
    Panel1: TPanel;
    CheckBox1: TCheckBox;
    CheckBox2: TCheckBox;
    CheckBox3: TCheckBox;
    Button1: TButton;
    ColorDialog1: TColorDialog;
    Button2: TButton;
    CheckBox4: TCheckBox;
    Button3: TButton;
    Button4: TButton;
    CheckBox5: TCheckBox;
    Button5: TButton;
    Button6: TButton;
    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);
    procedure CheckBox1Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure CheckBox4Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure CheckBox5Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
  private
    { Private declarations }
    FD3D            : IDIRECT3D8;
    FD3DDevice      : IDIRECT3DDEVICE8;
    FD3DVB          : IDIRECT3DVERTEXBUFFER8;
    FActive         : BOOL;
    ThisTickCount   : DWORD;
    LastTickCount   : DWORD;
    function Render : HRESULT;
    function InitD3D : HRESULT;
    function InitVB : HRESULT;
    procedure DrawScene;
    procedure Cleanup;
    procedure SetupLights;
    procedure ErrorOut (const Caption : PChar; const hError : HRESULT);
  public
    { Public declarations }
  end;

type
  TCUSTOMVERTEX = packed record
    X, Y, Z : Single;
    nX, nY, nZ : Single;
    U, V : Single;
  end;

const
  D3DFVF_CUSTOMVERTEX = D3DFVF_XYZ or D3DFVF_NORMAL or D3DFVF_TEX1;

var
  frmD3D: TfrmD3D;
  Frames : Integer = 0;

  Light : TD3DLight8;
  LightDirectional : TD3DLight8;

  MaterialTorus, MaterialSphere : TD3DMaterial8;

  Angle : Single = 0;

  Moving : BOOL = True;

const
{$I torus.pas}
{$I sphere.pas}

implementation

{$R *.DFM}

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;
       EnableAutoDepthStencil := True;
       AutoDepthStencilFormat := D3DFMT_D16;
  end;

  Result := FD3D.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, Panel1.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 or D3DCLEAR_ZBUFFER,
                           $000000FF, 1.0, 0);
  if FAILED(hRet) then begin
     Result := hRet;
     Exit;
  end;

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

  with FD3DDevice do begin
       SetRenderState(D3DRS_CULLMODE, D3DCULL_CCW);
       SetRenderState(D3DRS_ZENABLE, D3DZB_TRUE);
       SetRenderState(D3DRS_SPECULARENABLE, Dword (True));
       SetRenderState(D3DRS_NORMALIZENORMALS, Dword (True));
  end;

  DrawScene;

  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;
  matView, matProj : TD3DMatrix;
begin
  hRet := InitD3D;
  if Failed (hRet) then ErrorOut ('InitD3D', hRet);
  hRet := InitVB;
  if Failed (hRet) then ErrorOut ('InitVertex', hRet);

  MaterialTorus := InitMaterial(1, 1, 1, 0);
  with MaterialTorus.Specular do begin
       R := 1.0;
       G := 1.0;
       B := 1.0;
  end;

  MaterialSphere := MaterialTorus;

  SetupLights;

  SetViewMatrix(matView, D3DVector(0.0, 1.0, 1.0), D3DVector(0, 0, 0), D3DVector(0, 1, 0));
  FD3DDevice.SetTransform(D3DTS_VIEW, matView);

  SetProjectionMatrix(matProj, 1, 1, 0.1, 10);
  FD3DDevice.SetTransform(D3DTS_PROJECTION, matProj);
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 > 30 then begin
        Caption := 'FPS = ' + Format('%6.2f',
                                 [frames * 1000 / (ThisTickCount - LastTickCount)]);
        Frames := 0;

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

        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.InitVB : HRESULT;
var
  hRet : HRESULT;
  Vertices : ^TCustomVertex;
  i, j : Integer;
  vi : Integer;
  ni : Integer;
begin
  hRet := FD3DDevice.CreateVertexBuffer((864 + 1200) * 3 * SizeOf(TCustomVertex), 0,
                                        D3DFVF_CUSTOMVERTEX,
                                        D3DPOOL_DEFAULT, FD3DVB);
  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;

  hRet := FD3DDevice.SetVertexShader(D3DFVF_CUSTOMVERTEX);
  if Failed(hRet) then begin
     Result := hRet;
     Exit;
  end;

  hRet := FD3DVB.Lock(0, (864 + 1200) * 3 * SizeOf(TCustomVertex), PByte(Vertices), 0);
  if Failed(hRet) then begin
     Result := hRet;
     Exit;
  end;

  for i := 0 to 863 do
      for j := 0 to 2 do begin
      vi := Torusface_indicies[i][j];
      ni := Torusface_indicies[i][j+3];

         Vertices.X := TorusVertices[vi][0];
         Vertices.Y := TorusVertices[vi][1];
         Vertices.Z := TorusVertices[vi][2];

         Vertices.nX := Torusnormals[ni][0];
         Vertices.nY := Torusnormals[ni][1];
         Vertices.nZ := Torusnormals[ni][2];

         Inc(Vertices);
  end;

  for i := 0 to 1199 do
      for j := 0 to 2 do begin
      vi := Sphereface_indicies[i][j];
      ni := Sphereface_indicies[i][j+3];

         Vertices.X := SphereVertices[vi][0];
         Vertices.Y := SphereVertices[vi][1];
         Vertices.Z := SphereVertices[vi][2];

         Vertices.nX := Spherenormals[ni][0];
         Vertices.nY := Spherenormals[ni][1];
         Vertices.nZ := Spherenormals[ni][2];

         Inc(Vertices);
  end;

  Result := FD3DVB.Unlock;
end;

procedure TfrmD3D.DrawScene;
var
  matTranslate, matScale : TD3DMatrix;
begin
  Light.Position := D3DVector(0.0, cos (Angle) * 3, 0.0);
  with FD3DDevice do begin
       SetLight(1, LightDirectional);
       SetTransform(D3DTS_WORLD, IdentityMatrix);
       SetLight(0, Light);
       SetMaterial(MaterialTorus);
       DrawPrimitive(D3DPT_TRIANGLELIST, 0, 864);
  end;

  SetTranslateMatrix(matTranslate, 0.0, cos (Angle) * 3, 0.0);
  SetScaleMatrix(matScale, 0.1, 0.1, 0.1);
  Light.Position := D3DVector(0.0, 0.0, 0.0);
  with FD3DDevice do begin
       SetMaterial(MaterialSphere);
       SetTransform(D3DTS_WORLD, MatrixMul(matScale, matTranslate));
       SetLight(0, Light);
       DrawPrimitive(D3DPT_TRIANGLELIST, 864 * 3, 1200);
  end;
end;

procedure TfrmD3D.SetupLights;
begin
  ZeroMemory(@Light , SizeOf(Light));
  with Light do begin
       _Type := D3DLIGHT_POINT;
       Diffuse.R := 1.0;
       Diffuse.G := 1.0;
       Diffuse.B := 1.0;
       Specular := Diffuse;
       Ambient := Diffuse;
       Position := D3DVector(0.0, 0.0, 0.0);
       Attenuation0 := 1.0;
       Attenuation1 := 1.0;
       Attenuation2 := 1.0;
       Range := 2.0;
  end;

  LightDirectional := InitDirectionalLight(D3DVector(0.0, -1.0, -1.0), 1.0, 1.0, 1.0, 0);

  with FD3DDevice do begin
       SetLight(0, Light);
       SetLight(1, LightDirectional);
       LightEnable(0, True);
  end;
end;

procedure TfrmD3D.CheckBox1Click(Sender: TObject);
begin
  if CheckBox1.Checked
     then Light.Attenuation0 := 1.0
     else Light.Attenuation0 := 0.0;

  if CheckBox2.Checked
     then Light.Attenuation1 := 1.0
     else Light.Attenuation1 := 0.0;

  if CheckBox3.Checked
     then Light.Attenuation2 := 1.0
     else Light.Attenuation2 := 0.0;
end;

procedure TfrmD3D.CheckBox4Click(Sender: TObject);
begin
  Moving := CheckBox4.Checked;
end;

procedure TfrmD3D.Button1Click(Sender: TObject);
var
  wrkR, wrkG, wrkB : Single;
begin
  ColorDialog1.Color :=
  Round(MaterialSphere.Diffuse.R * 255) + Round(MaterialSphere.Diffuse.G * 255 * $100) +
  Round(MaterialSphere.Diffuse.B * 255 * $10000);

  if ColorDialog1.Execute then begin
     wrkR := (ColorDialog1.Color and $FF) / 255;
     wrkG := ((ColorDialog1.Color and $FF00) shr 8) / 255;
     wrkB := ((ColorDialog1.Color and $FF0000) shr 16) / 255;
     with Light.Diffuse do begin
       R := wrkR;
       G := wrkG;
       B := wrkB;
     end;
     with LightDirectional.Diffuse do begin
       R := wrkR;
       G := wrkG;
       B := wrkB;
     end;
     with MaterialSphere.Diffuse do begin
       R := wrkR;
       G := wrkG;
       B := wrkB;
     end;
  end;
end;

procedure TfrmD3D.Button2Click(Sender: TObject);
begin
  ColorDialog1.Color := 
  Round(MaterialTorus.Diffuse.R * 255) + Round(MaterialTorus.Diffuse.G * 255 * $100) +
  Round(MaterialTorus.Diffuse.B * 255 * $10000);

  if ColorDialog1.Execute then
     with MaterialTorus.Diffuse do begin
       R := (ColorDialog1.Color and $FF) / 255;
       G := ((ColorDialog1.Color and $FF00) shr 8) / 255;
       B := ((ColorDialog1.Color and $FF0000) shr 16) / 255;
  end;
end;

procedure TfrmD3D.Button3Click(Sender: TObject);
begin
  ColorDialog1.Color :=
  Round(MaterialTorus.Ambient.R * 255) + Round(MaterialTorus.Ambient.G * 255 * $100) +
  Round(MaterialTorus.Ambient.B * 255 * $10000);

  if ColorDialog1.Execute then
     with MaterialTorus.Ambient do begin
       R := (ColorDialog1.Color and $FF) / 255;
       G := ((ColorDialog1.Color and $FF00) shr 8) / 255;
       B := ((ColorDialog1.Color and $FF0000) shr 16) / 255;
  end;
end;

procedure TfrmD3D.Button4Click(Sender: TObject);
begin
  ColorDialog1.Color :=
  Round(MaterialTorus.Specular.R * 255) + Round(MaterialTorus.Specular.G * 255 * $100) +
  Round(MaterialTorus.Specular.B * 255 * $10000);

  if ColorDialog1.Execute then
     with MaterialTorus.Specular do begin
       R := (ColorDialog1.Color and $FF) / 255;
       G := ((ColorDialog1.Color and $FF00) shr 8) / 255;
       B := ((ColorDialog1.Color and $FF0000) shr 16) / 255;
  end;
end;

procedure TfrmD3D.CheckBox5Click(Sender: TObject);
begin
  with FD3DDevice do begin
       LightEnable(1, CheckBox5.Checked);
       LightEnable(0, not CheckBox5.Checked);
  end;
end;

procedure TfrmD3D.Button5Click(Sender: TObject);
var
  wrkR, wrkG, wrkB : Single;
begin
  ColorDialog1.Color :=
  Round(MaterialSphere.Ambient.R * 255) + Round(MaterialSphere.Ambient.G * 255 * $100) +
  Round(MaterialSphere.Ambient.B * 255 * $10000);

  if ColorDialog1.Execute then begin
     wrkR := (ColorDialog1.Color and $FF) / 255;
     wrkG := ((ColorDialog1.Color and $FF00) shr 8) / 255;
     wrkB := ((ColorDialog1.Color and $FF0000) shr 16) / 255;
     with Light.Ambient do begin
       R := wrkR;
       G := wrkG;
       B := wrkB;
     end;
     with MaterialSphere.Ambient do begin
       R := wrkR;
       G := wrkG;
       B := wrkB;
     end;
     with LightDirectional.Ambient do begin
       R := wrkR;
       G := wrkG;
       B := wrkB;
     end;
  end;
end;

procedure TfrmD3D.Button6Click(Sender: TObject);
var
  wrkR, wrkG, wrkB : Single;
begin
  ColorDialog1.Color :=
  Round(MaterialSphere.Specular.R * 255) + Round(MaterialSphere.Specular.G * 255 * $100) +
  Round(MaterialSphere.Specular.B * 255 * $10000);

  if ColorDialog1.Execute then begin
     wrkR := (ColorDialog1.Color and $FF) / 255;
     wrkG := ((ColorDialog1.Color and $FF00) shr 8) / 255;
     wrkB := ((ColorDialog1.Color and $FF0000) shr 16) / 255;
     with Light.Specular do begin
       R := wrkR;
       G := wrkG;
       B := wrkB;
     end;
     with MaterialSphere.Specular do begin
       R := wrkR;
       G := wrkG;
       B := wrkB;
     end;
     with LightDirectional.Specular do begin
       R := wrkR;
       G := wrkG;
       B := wrkB;
     end;
  end;
end;

end.
