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

interface

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

type
  TfrmD3D = class(TForm)
    ApplicationEvents1: TApplicationEvents;
    Panel1: TPanel;
    tbStart: TTrackBar;
    Label1: TLabel;
    Label2: TLabel;
    tbEnd: TTrackBar;
    tbDensity: TTrackBar;
    Label3: TLabel;
    Label4: TLabel;
    tbRed: TTrackBar;
    tbGreen: TTrackBar;
    tbBlue: TTrackBar;
    cmbxFOGTABLEMODE: TComboBox;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    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 tbStartChange(Sender: TObject);
    procedure tbEndChange(Sender: TObject);
    procedure tbDensityChange(Sender: TObject);
    procedure tbRedChange(Sender: TObject);
    procedure cmbxFOGTABLEMODEChange(Sender: TObject);
  private
    { Private declarations }
    FD3D            : IDIRECT3D8;
    FD3DDevice      : IDIRECT3DDEVICE8;
    FD3DVB          : IDIRECT3DVERTEXBUFFER8;
    FActive         : BOOL;
    MaterialConus    : TD3DMaterial8;
    MaterialWhite   : TD3DMaterial8;
    MaterialSphere  : TD3DMaterial8;    
    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;
  end;

const
  D3DFVF_CUSTOMVERTEX = D3DFVF_XYZ or D3DFVF_NORMAL;

var
  frmD3D: TfrmD3D;
  Frames : Integer = 0;

  Angle : Single = 0.0;

{$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;

var
  FogDensity : Single = 1.0;
  FogStart : Single = 0.4;
  FogEnd : Single = 1.0;
  FogColor : DWORD = $00FFFFFF;
  FOGTABLEMODE : DWORD = D3DFOG_LINEAR;

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,
                           $00FFFFFF, 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_AMBIENT, $00202020);
       SetRenderState(D3DRS_LIGHTING, Dword (True));
       SetRenderState(D3DRS_NORMALIZENORMALS, DWORD (True));
       SetRenderState(D3DRS_FOGENABLE, DWORD (True));
       SetRenderState(D3DRS_FOGTABLEMODE, FOGTABLEMODE);
       SetRenderState(D3DRS_FOGCOLOR, FogColor);
       SetRenderState(D3DRS_FOGDENSITY, PDWORD (@FogDensity)^);
       SetRenderState(D3DRS_FOGSTART, PDWORD (@FogStart)^);
       SetRenderState(D3DRS_FOGEND, PDWORD (@FogEnd)^);
  end;

  DrawScene;

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

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

var
  matCone : TD3DMatrix;
  matSphere : TD3DMatrix;

procedure TfrmD3D.FormCreate(Sender: TObject);
var
  hRet : HRESULT;
  matView, matProj : TD3DMatrix;
  matRotate, matTranslate, matScale : TD3DMatrix;

begin
  hRet := InitD3D;
  if Failed (hRet) then ErrorOut ('InitD3D', hRet);
  hRet := InitVB;
  if Failed (hRet) then ErrorOut ('InitVertex', hRet);

  MaterialConus := InitMaterial(0, 0.5, 1, 0);
  MaterialWhite := InitMaterial(1, 1, 1, 0);
  MaterialSphere := InitMaterial(1, 0.5, 0, 0);

  SetViewMatrix(matView, D3DVector(0, 0, 2.577), D3DVector(0, 0, -5), D3DVector(0, 1, 0));
  FD3DDevice.SetTransform(D3DTS_VIEW, matView);

  SetProjectionMatrix(matProj, 1, 1, 1, 10);
  FD3DDevice.SetTransform(D3DTS_PROJECTION, matProj);

  SetupLights;

  SetRotateXMatrix(matRotate, -Pi / 2);
  SetTranslateMatrix(matTranslate, 0.0, -1.0, 0.0);
  SetScaleMatrix(matScale, 0.25, 1.0, 0.2);
  matCone := MatrixMul(matScale, MatrixMul(matTranslate, matRotate));
  matSphere := IdentityMatrix;
  matSphere._42 := -0.5;
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 > 15 then begin
        Caption := 'FPS = ' + Format('%6.2f',
                                 [frames * 1000 / (ThisTickCount - LastTickCount)]);
        Frames := 0;

        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.InitVB : HRESULT;
var
  Vertices : ^TCustomVertex;
  hRet : HRESULT;
  theta : Single;
  i, j : Integer;
  vi : Integer;
  ni : Integer;
begin
  hRet := FD3DDevice.CreateVertexBuffer((30 + 51 + 51 + 3600) * 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, (30 + 51 + 51 + 3600) * SizeOf(TCustomVertex), PByte(Vertices), 0);
  if Failed(hRet) then begin
     Result := hRet;
     Exit;
  end;

  Vertices.X := -1.0;
  Vertices.Y := -1.0;
  Vertices.Z :=  1.0;
  Vertices.nX := 0.0;
  Vertices.nY := 1.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X :=  1.0;
  Vertices.Y := -1.0;
  Vertices.Z :=  1.0;
  Vertices.nX := 0.0;
  Vertices.nY := 1.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X :=  1.0;
  Vertices.Y := -1.0;
  Vertices.Z :=  -1.0;
  Vertices.nX := 0.0;
  Vertices.nY := 1.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X := -1.0;
  Vertices.Y := -1.0;
  Vertices.Z :=  1.0;
  Vertices.nX := 0.0;
  Vertices.nY := 1.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X :=  1.0;
  Vertices.Y := -1.0;
  Vertices.Z :=  -1.0;
  Vertices.nX := 0.0;
  Vertices.nY := 1.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X := -1.0;
  Vertices.Y := -1.0;
  Vertices.Z := -1.0;
  Vertices.nX := 0.0;
  Vertices.nY := 1.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X := -1.0;
  Vertices.Y :=  1.0;
  Vertices.Z := -1.0;
  Vertices.nX := 0.0;
  Vertices.nY := -1.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X :=  1.0;
  Vertices.Y :=  1.0;
  Vertices.Z :=  -1.0;
  Vertices.nX := 0.0;
  Vertices.nY := -1.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X :=  1.0;
  Vertices.Y :=  1.0;
  Vertices.Z :=  1.0;
  Vertices.nX := 0.0;
  Vertices.nY := -1.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X := -1.0;
  Vertices.Y :=  1.0;
  Vertices.Z := -1.0;
  Vertices.nX := 0.0;
  Vertices.nY := -1.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X :=  1.0;
  Vertices.Y :=  1.0;
  Vertices.Z :=  1.0;
  Vertices.nX := 0.0;
  Vertices.nY := -1.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X := -1.0;
  Vertices.Y :=  1.0;
  Vertices.Z :=  1.0;
  Vertices.nX := 0.0;
  Vertices.nY := -1.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X := -1.0;
  Vertices.Y := -1.0;
  Vertices.Z := -1.0;
  Vertices.nX := 1.0;
  Vertices.nY := 0.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X := -1.0;
  Vertices.Y :=  1.0;
  Vertices.Z :=  1.0;
  Vertices.nX := 1.0;
  Vertices.nY := 0.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X := -1.0;
  Vertices.Y := -1.0;
  Vertices.Z :=  1.0;
  Vertices.nX := 1.0;
  Vertices.nY := 0.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X := -1.0;
  Vertices.Y := -1.0;
  Vertices.Z := -1.0;
  Vertices.nX := 1.0;
  Vertices.nY := 0.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X := -1.0;
  Vertices.Y :=  1.0;
  Vertices.Z := -1.0;
  Vertices.nX := 1.0;
  Vertices.nY := 0.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X := -1.0;
  Vertices.Y :=  1.0;
  Vertices.Z :=  1.0;
  Vertices.nX := 1.0;
  Vertices.nY := 0.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X :=  1.0;
  Vertices.Y :=  1.0;
  Vertices.Z := -1.0;
  Vertices.nX := -1.0;
  Vertices.nY := 0.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X :=  1.0;
  Vertices.Y := -1.0;
  Vertices.Z :=  1.0;
  Vertices.nX := -1.0;
  Vertices.nY := 0.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X :=  1.0;
  Vertices.Y :=  1.0;
  Vertices.Z :=  1.0;
  Vertices.nX := -1.0;
  Vertices.nY := 0.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X :=  1.0;
  Vertices.Y :=  1.0;
  Vertices.Z := -1.0;
  Vertices.nX := -1.0;
  Vertices.nY := 0.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X :=  1.0;
  Vertices.Y := -1.0;
  Vertices.Z := -1.0;
  Vertices.nX := -1.0;
  Vertices.nY := 0.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X :=  1.0;
  Vertices.Y := -1.0;
  Vertices.Z :=  1.0;
  Vertices.nX := -1.0;
  Vertices.nY := 0.0;
  Vertices.nZ := 0.0;
  Inc(Vertices);

  Vertices.X := -1.0;
  Vertices.Y := -1.0;
  Vertices.Z := -1.0;
  Vertices.nX := 0.0;
  Vertices.nY := 0.0;
  Vertices.nZ := 1.0;
  Inc(Vertices);

  Vertices.X :=  1.0;
  Vertices.Y := -1.0;
  Vertices.Z := -1.0;
  Vertices.nX := 0.0;
  Vertices.nY := 0.0;
  Vertices.nZ := 1.0;
  Inc(Vertices);

  Vertices.X :=  1.0;
  Vertices.Y :=  1.0;
  Vertices.Z := -1.0;
  Vertices.nX := 0.0;
  Vertices.nY := 0.0;
  Vertices.nZ := 1.0;
  Inc(Vertices);

  Vertices.X := -1.0;
  Vertices.Y := -1.0;
  Vertices.Z := -1.0;
  Vertices.nX := 0.0;
  Vertices.nY := 0.0;
  Vertices.nZ := 1.0;
  Inc(Vertices);

  Vertices.X :=  1.0;
  Vertices.Y :=  1.0;
  Vertices.Z := -1.0;
  Vertices.nX := 0.0;
  Vertices.nY := 0.0;
  Vertices.nZ := 1.0;
  Inc(Vertices);

  Vertices.X := -1.0;
  Vertices.Y :=  1.0;
  Vertices.Z := -1.0;
  Vertices.nX := 0.0;
  Vertices.nY := 0.0;
  Vertices.nZ := 1.0;
  Inc(Vertices);

  Vertices.X := 0.0;
  Vertices.Y := 0.0;
  Vertices.Z := 1.0;
  Vertices.nX := 0.0;
  Vertices.nY := 0.0;
  Vertices.nZ := 1.0;
  Inc(Vertices);

  for i := 0 to 49 do begin
    theta := 2 * Pi * i / 49;
    Vertices.X := cos(theta);
    Vertices.Y := sin(theta);
    Vertices.Z := 0.0;
    Vertices.nX := cos(theta);
    Vertices.nY := sin(theta);
    Vertices.nZ := 1.0;
    Inc(Vertices);
  end;

  Vertices.X := 0.0;
  Vertices.Y := 0.0;
  Vertices.Z := 0.0;
  Vertices.nX := 0.0;
  Vertices.nY := 0.0;
  Vertices.nZ := -1.0;
  Inc(Vertices);

  for i := 0 to 49 do begin
    theta := 2 * Pi * i / 49;
    Vertices.X := sin(theta);
    Vertices.Y := cos(theta);
    Vertices.Z := 0.0;
    Vertices.nX := 0.0;
    Vertices.nY := 0.0;
    Vertices.nZ := -1.0;
    Inc(Vertices);
  end;

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

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

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

         Inc(Vertices);
  end;

  Result := FD3DVB.Unlock;
end;

procedure TfrmD3D.DrawScene;
begin
  with FD3DDevice do begin
       SetTransform(D3DTS_WORLD, IdentityMatrix);
       SetMaterial(MaterialWhite);
       LightEnable(0, True);
       LightEnable(1, True);
       LightEnable(2, True);
       LightEnable(3, False);
       DrawPrimitive(D3DPT_TRIANGLELIST, 0, 10);
  end;

  with FD3DDevice do begin
       LightEnable(0, False);
       LightEnable(1, False);
       LightEnable(2, False);
       LightEnable(3, True);
       SetMaterial(MaterialConus);
       SetTransform(D3DTS_WORLD, matCone);
       DrawPrimitive(D3DPT_TRIANGLEFAN, 30, 49);
       DrawPrimitive(D3DPT_TRIANGLEFAN, 81, 49);
  end;

  matSphere._41 := cos (Angle) / 2;
  matSphere._43 := sin (Angle) / 2;

  with FD3DDevice do begin
       SetTransform(D3DTS_WORLD, matSphere);
       SetMaterial(MaterialSphere);
       DrawPrimitive(D3DPT_TRIANGLELIST, 30 + 51 + 51, 1200);
  end;
end;

procedure TfrmD3D.SetupLights;
var
  Light0     : TD3DLight8;
  Light1     : TD3DLight8;
  Light2     : TD3DLight8;
  Light3     : TD3DLight8;
begin
  ZeroMemory(@Light0 , SizeOf(Light0));
  with Light0 do begin
       _Type := D3DLIGHT_POINT;
       Diffuse.r := 0.4;
       Diffuse.g := 0.4;
       Diffuse.b := 0.4;
       Specular := Diffuse;
       Ambient := Diffuse;
       Position := D3DVector(0.5, 0.75, 1.5);
       Attenuation0 := 1.0;
       Attenuation1 := 1.0;
       Attenuation2 := 0.0;
       Range := 2.56;
  end;

  ZeroMemory(@Light1 , SizeOf(Light1));
  with Light1 do begin
       _Type := D3DLIGHT_POINT;
       Diffuse.r := 0.4;
       Diffuse.g := 0.4;
       Diffuse.b := 0.4;
       Specular := Diffuse;
       Ambient := Diffuse;
       Position := D3DVector(0.5, 0.3, 0.3);
       Attenuation0 := 1.0;
       Attenuation1 := 1.0;
       Attenuation2 := 0.0;
       Range := 2.5;
  end;

  ZeroMemory(@Light2 , SizeOf(Light1));
  with Light2 do begin
       _Type := D3DLIGHT_POINT;
       Diffuse.r := 0.4;
       Diffuse.g := 0.4;
       Diffuse.b := 0.4;
       Specular := Diffuse;
       Ambient := Diffuse;
       Position := D3DVector(0.5, -0.3, 0.3);
       Attenuation0 := 1.0;
       Attenuation1 := 1.0;
       Attenuation2 := 0.0;
       Range := 2.5;
  end;

  Light3 := InitDirectionalLight(D3DVector(-0.5, -0.5, -1), 1.0, 1.0, 1.0, 0);

  with FD3DDevice do begin
       SetLight(0, Light0);
       SetLight(1, Light1);
       SetLight(2, Light2);
       SetLight(3, Light3);
  end;
end;

procedure TfrmD3D.tbStartChange(Sender: TObject);
begin
  FogStart := tbStart.Position / 10;
end;

procedure TfrmD3D.tbEndChange(Sender: TObject);
begin
  FogEnd := tbEnd.Position / 10;
end;

procedure TfrmD3D.tbDensityChange(Sender: TObject);
begin
  FogDensity := tbDensity.Position / 10;
end;

procedure TfrmD3D.tbRedChange(Sender: TObject);
begin
  FogColor := tbBlue.Position + (tbGreen.Position shl 8) + (tbRed.Position shl (4 * 4));
end;

procedure TfrmD3D.cmbxFOGTABLEMODEChange(Sender: TObject);
begin
  case cmbxFOGTABLEMODE.ItemIndex of
       0 : FOGTABLEMODE := D3DFOG_NONE;
       1 : FOGTABLEMODE := D3DFOG_EXP;
       2 : FOGTABLEMODE := D3DFOG_EXP2;
       3 : FOGTABLEMODE := D3DFOG_LINEAR;
  end;
end;

end.
