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

interface

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

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;
    FD3Texture      : IDIRECT3DTEXTURE8;
    ThisTickCount   : DWORD;
    LastTickCount   : DWORD;
    function Render : HRESULT;
    function InitD3D : HRESULT;
    function InitVB : HRESULT;
    function InitTexture (const FileName : String) : HRESULT;
    procedure SetupMatrices;
    procedure SetupLights;
    procedure Cleanup;
    procedure ErrorOut (const Caption : PChar; const hError : HRESULT);
    procedure InitSphere;
  public
    { Public declarations }
  end;

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

const
  D3DFVF_CUSTOMVERTEX = D3DFVF_XYZ or D3DFVF_NORMAL or D3DFVF_DIFFUSE or D3DFVF_TEX1;

var
  frmD3D: TfrmD3D;
  Frames : Integer = 0;

  Angle : Single = 0.0;

implementation

{$R *.DFM}

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

  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
  FD3Texture := nil;
  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, 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, $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);
       SetTexture(0, FD3Texture);

       SetTextureStageState(0, D3DTSS_COLOROP, D3DTOP_MODULATE);
       SetRenderState(D3DRS_LIGHTING, DWORD (True));
  end;

  SetupMatrices;

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

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

var
  wrkWorld : TD3DMatrix;

procedure TfrmD3D.FormCreate(Sender: TObject);
var
  hRet : HRESULT;
  View, Proj : TD3DMatrix;
begin
  hRet := InitD3D;
  if Failed (hRet) then ErrorOut ('InitD3D', hRet);
  hRet := InitVB;
  if Failed (hRet) then ErrorOut ('InitVertex', hRet);
  hRet := InitTexture ('../earth.bmp');
  if Failed (hRet) then ErrorOut ('InitTexture', hRet);

  InitSphere;

  SetupLights;

  SetRotateXMatrix (wrkWorld, Pi / 4);

  FD3DDevice.SetTransform(D3DTS_WORLD, wrkWorld);

  SetViewMatrix(View, D3DVector(0, 0, -2.5), D3DVector(0, 0, 0), D3DVector(0, 1, 0));
  FD3DDevice.SetTransform(D3DTS_VIEW, View);

  SetProjectionMatrix(Proj, 1, 1, 1, 5);
  FD3DDevice.SetTransform(D3DTS_PROJECTION, Proj);
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
  hRet : HRESULT;
begin
  hRet := FD3DDevice.CreateVertexBuffer(5000 * 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;

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

procedure TfrmD3D.SetupMatrices;
var
  matRot : TD3DMatrix;
begin
  SetRotateZMatrix (matRot, Angle);

  FD3DDevice.SetTransform(D3DTS_WORLD, MatrixMul(wrkWorld, matRot));

  FD3DDevice.DrawPrimitive(D3DPT_TRIANGLESTRIP, 0, 5000 - 2);
end;

procedure TfrmD3D.SetupLights;
var
  Light : TD3DLight8;
begin
  Light := InitDirectionalLight(D3DVector(-1, -1, 1), 1, 1, 1, 0);

  FD3DDevice.SetLight(0, Light);
  FD3DDevice.LightEnable(0, True);
end;

procedure TfrmD3D.InitSphere;
procedure CalcNormals (const wrkVector1, wrkVector2, wrkVector3 : TD3DVector;
                       var wrkVector : TD3DVector);
var
     nx, ny, nz : Single;
begin
     nx := (wrkVector1.X + wrkVector2.X + wrkVector3.X) / 3;
     ny := (wrkVector1.Y + wrkVector2.Y + wrkVector3.Y) / 3;
     nz := (wrkVector1.Z + wrkVector2.Z + wrkVector3.Z) / 3;

     wrkVector := VectorNormalize (D3DVector (nx, ny, nz));
end;
const
   drho = PI / 49;
   dtheta = 2.0 * PI / 49;
var
  Vertices : ^TCustomVertex;
  theta, rho    : Single;
  i, j : Integer;
  X1, Y1, Z1 : Single;
  X2, Y2, Z2 : Single;
  X3, Y3, Z3 : Single;
  nV : TD3DVector;
begin
  FD3DVB.Lock(0, 5000 * SizeOf(TCustomVertex), PByte(Vertices), 0);

  for i := 0 to 48 do begin
      rho := i * drho;
      for j := 0 to 49 do begin
         theta := j * dtheta;

         X1 := -sin(theta) * sin(rho);
         Y1 := cos(theta) * sin(rho);
         Z1 := cos(rho);

         X2 := -sin(theta) * sin( rho + drho);
         Y2 := cos(theta) * sin( rho + drho);
         Z2 := cos(rho + drho);

         X3 := -sin((j + 1) * dtheta) * sin(rho);
         Y3 := cos((j + 1) * dtheta) * sin(rho);
         Z3 := cos(rho);

         CalcNormals (D3DVector (X1, Y1, Z1), D3DVector (X2, Y2, Z2), D3DVector (X3, Y3, Z3),
                      nV);
         if i = 0 then begin
         Vertices.X := X1;
         Vertices.Y := Y1;
         Vertices.Z := Z1;
         Vertices.nX := nV.X;
         Vertices.nY := nV.Y;
         Vertices.nZ := nV.Z;
         Vertices.DColor := D3DCOLOR_XRGB(255, 255, 255);
         Vertices.U := j / 49;
         Vertices.V := i / 49;
         Inc(Vertices);

         Vertices.X := X2;
         Vertices.Y := Y2;
         Vertices.Z := Z2;
         Vertices.nX := nV.X;
         Vertices.nY := nV.Y;
         Vertices.nZ := nV.Z;
         Vertices.DColor := D3DCOLOR_XRGB(255, 255, 255);
         Vertices.U := j / 49;
         Vertices.V := (i + 1) / 49;
         Inc(Vertices);
         end;

         Vertices.X := X3;
         Vertices.Y := Y3;
         Vertices.Z := Z3;
         Vertices.nX := nV.X;
         Vertices.nY := nV.Y;
         Vertices.nZ := nV.Z;
         Vertices.DColor := D3DCOLOR_XRGB(255, 255, 255);
         Vertices.U := (j + 1)/ 49;
         Vertices.V := i / 49;
         Inc(Vertices);

         X1 := -sin((j + 1) * dtheta) * sin((i + 1) * drho);
         Y1 := cos((j + 1) * dtheta) * sin((i + 1) * drho);
         Z1 := cos((i + 1) * drho);

         X2 := -sin(theta) * sin((i + 1) * drho+drho);
         Y2 := cos(theta) * sin((i + 1) * drho+drho);
         Z2 := cos((i + 1) * drho+drho);

         X3 := -sin((j + 1) * dtheta) * sin(i * drho+drho);
         Y3 := cos((j + 1) * dtheta) * sin(i * drho+drho);
         Z3 := cos(i * drho+drho);

         CalcNormals (D3DVector (X1, Y1, Z1), D3DVector (X2, Y2, Z2), D3DVector (X3, Y3, Z3),
                      nV);

         Vertices.X := X1;
         Vertices.Y := Y1;
         Vertices.Z := Z1;
         Vertices.nX := nV.X;
         Vertices.nY := nV.Y;
         Vertices.nZ := nV.Z;
         Vertices.DColor := D3DCOLOR_XRGB(255, 255, 255);
         Vertices.U := (j + 1) / 49;
         Vertices.V := (i + 1) / 49;
         Inc(Vertices);
  end;
  end;

  FD3DVB.Unlock;
end;

function TfrmD3D.InitTexture (const FileName : String) : HRESULT;
var
  hRet : HRESULT;
  d3dlr : TD3DLOCKED_RECT;
  dwDstPitch : DWORD;
  X, Y : DWORD;
  Bmp : tBitmap;
  R, G, B : Byte;
begin
  Bmp := TBitmap.Create;
  Bmp.LoadFromfile (FileName);

  hRet := FD3DDevice.CreateTexture (Bmp.Width, Bmp.Height, 0, 0,
                                    D3DFMT_A8R8G8B8,
                                    D3DPOOL_MANAGED, FD3Texture);
  if FAILED(hRet) then begin
     Result := hRet;
     Exit;
  end;

  hRet := FD3Texture.LockRect(0, d3dlr, nil, 0);
  if FAILED(hRet) then begin
     Result := hRet;
     Exit;
  end;

  dwDstPitch := d3dlr.Pitch;
  for Y := 0 to Bmp.Height - 1 do
      for X := 0 to Bmp.Width - 1 do begin
         R := GetRValue (Bmp.Canvas.Pixels [X, DWORD (Bmp.Height - 1) - Y]);
         G := GetGValue (Bmp.Canvas.Pixels [X, DWORD (Bmp.Height - 1) - Y]);
         B := GetBValue (Bmp.Canvas.Pixels [X, DWORD (Bmp.Height - 1) - Y]);

         PDWORD (DWORD(d3dlr.pBits) + Y * dwDstPitch + X * 4)^ := D3DCOLOR_XRGB(R, G, B)
  end;
  Bmp.Free;

  Result := FD3Texture.UnlockRect(0);
end;

end.
