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

interface

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

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);
    procedure ApplicationEvents1Deactivate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
    FD3D            : IDIRECT3D8;
    FD3DDevice      : IDIRECT3DDEVICE8;
    FD3DVB          : IDIRECT3DVERTEXBUFFER8;
    FActive         : BOOL;
    function Render : HRESULT;
    function InitD3D : HRESULT;
    function InitVB : HRESULT;
    function OnCreateDevice : HRESULT;
    function ReadImmediateData : 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;
  TSPHERE = packed record
    Z : Single;
    Radius : Single;
    matSphere : TD3DMatrix;
    MaterialSphere : TD3DMaterial8;
  end;

const
  D3DFVF_CUSTOMVERTEX = D3DFVF_XYZ or D3DFVF_NORMAL;
  NumSpheres = 60;

var
  frmD3D: TfrmD3D;

  Spheres : Array [0..NumSpheres - 1] of TSPHERE;
  MaterialXWing  : TD3DMaterial8;
  matXWing : TD3DMatrix;

  DInput : IDIRECTINPUT8 = nil;
  DIMouse : IDIRECTINPUTDEVICE8 = nil;

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;

const
  fmtFullscreenArray : Array [0..4] of DWORD =
       (D3DFMT_R5G6B5,
        D3DFMT_X1R5G5B5,
        D3DFMT_A1R5G5B5,
        D3DFMT_X8R8G8B8,
        D3DFMT_A8R8G8B8);

var
  FD3DfmtFullscreen : DWORD;
  ScreenWidth, ScreenHeight : Integer;
  d3dpp : TD3DPRESENT_PARAMETERS;

function TfrmD3D.InitD3D : HRESULT;
var
  iFmt : Integer;
begin
  if FD3D = nil then FD3D := Direct3DCreate8(D3D_SDK_VERSION);
  if FD3D = nil then begin
     Result := E_FAIL;
     Exit;
  end;

  for iFmt := 0 to High(fmtFullscreenArray) do begin
      if( SUCCEEDED( FD3D.CheckDeviceType( D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL,
            fmtFullscreenArray[iFmt], fmtFullscreenArray[iFmt], FALSE ) ) )
        then begin
            FD3DfmtFullscreen := fmtFullscreenArray[iFmt];
            Break;
        end
  end;

  ScreenWidth := GetSystemMetrics(SM_CXSCREEN);
  ScreenHeight := GetSystemMetrics(SM_CYSCREEN);

  ZeroMemory(@d3dpp, SizeOf(d3dpp));
  with d3dpp do begin
       Windowed := False;
       SwapEffect := D3DSWAPEFFECT_DISCARD;
       BackBufferWidth  := ScreenWidth;
       BackBufferHeight := ScreenHeight;
       BackBufferFormat := FD3DfmtFullscreen;
       EnableAutoDepthStencil := True;
       AutoDepthStencilFormat := D3DFMT_D16;
  end;

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

function TfrmD3D.Render : HRESULT;
begin
  FD3DDevice.Clear(0, nil, D3DCLEAR_TARGET or D3DCLEAR_ZBUFFER,
                           $00FFFFFF, 1.0, 0);

  FD3DDevice.BeginScene;

  with FD3DDevice do begin
       SetRenderState(D3DRS_ZENABLE, D3DZB_TRUE);
       SetRenderState(D3DRS_NORMALIZENORMALS, DWORD (True));
  end;

  DrawScene;

  FD3DDevice.EndScene;

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

procedure TfrmD3D.FormCreate(Sender: TObject);
var
  hRet : HRESULT;
  matView, matProj : TD3DMatrix;
  i : Integer;
  matWrk : TD3DMatrix;
begin
  ShowCursor (False);

  hRet := OnCreateDevice;
  if Failed (hRet) then ErrorOut ('InitDirectInput', hRet);
  hRet := InitD3D;
  if Failed (hRet) then ErrorOut ('InitD3D', hRet);
  hRet := InitVB;
  if Failed (hRet) then ErrorOut ('InitVertex', hRet);
  SetupLights;

  for i := 0 to NumSpheres - 1 do
    with Spheres [i] do begin
      Z := random * 80 - 40;
      Radius := random * 0.1 + 0.1;
      SetScaleMatrix(matSphere, Radius, Radius, Radius);
      SetTranslateMatrix (matWrk, random * 20 - 10, random * 20 - 10, Z);
      matSphere := MatrixMul (matSphere, matWrk);
      MaterialSphere := InitMaterial(random * 0.5 + 0.5, random * 0.5 + 0.5, random * 0.5 + 0.5, 0);
  end;

  MaterialXWing := InitMaterial(1.0, 1.0, 0.0, 0);

  SetRotateXMatrix(matXWing, -Pi / 2);

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

  SetProjectionMatrix(matProj, 1, 1, 1, 100);
  FD3DDevice.SetTransform(D3DTS_PROJECTION, matProj);
end;

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

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

procedure TfrmD3D.ApplicationEvents1Idle(Sender: TObject;
  var Done: Boolean);
var
  hRet : HRESULT;
begin
  if FActive then begin
     ReadImmediateData;

     hRet := Render;
     if FAILED(hRet) then begin
        FActive := False;
        ErrorOut ('Render', hRet);
        Exit;
     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);
var
  matView, matProj : TD3DMatrix;
begin
  if Assigned (FD3DVB) then begin
     FD3DVB._Release;
     FD3DVB := nil;
  end;
  WindowState := wsMaximized;

  InitD3D;

  InitVB;

  SetupLights;

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

  SetProjectionMatrix(matProj, 1, 1, 1, 100);
  FD3DDevice.SetTransform(D3DTS_PROJECTION, matProj);
  FActive := True;
end;

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

function TfrmD3D.InitVB : HRESULT;
var
  Vertices : ^TCustomVertex;
  hRet : HRESULT;
  t : TextFile;
  wX, wY, wZ : Single;
begin
  hRet := FD3DDevice.CreateVertexBuffer((2498 * 3 + 110 * 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, (2498 * 3 + 110 * 3) * SizeOf(TCustomVertex), PByte(Vertices), 0);
  if Failed(hRet) then begin
     Result := hRet;
     Exit;
  end;

  AssignFile (t, 'XWING.txt');
  Reset (t);
  while not EOF(t) do begin
    Readln (t, wX);
    Readln (t, wY);
    Readln (t, wZ);

    Readln (t, Vertices.X);
    Readln (t, Vertices.Y);
    Readln (t, Vertices.Z);
    Vertices.nX := wX;
    Vertices.nY := wY;
    Vertices.nZ := wZ;
    Inc (Vertices);

    Readln (t, Vertices.X);
    Readln (t, Vertices.Y);
    Readln (t, Vertices.Z);
    Vertices.nX := wX;
    Vertices.nY := wY;
    Vertices.nZ := wZ;
    Inc (Vertices);

    Readln (t, Vertices.X);
    Readln (t, Vertices.Y);
    Readln (t, Vertices.Z);
    Vertices.nX := wX;
    Vertices.nY := wY;
    Vertices.nZ := wZ;
    Inc (Vertices);
  end;
  CloseFile (t);

  AssignFile (t, 'sphere.txt');
  Reset (t);
  while not EOF(t) do begin
    Readln (t, wX);
    Readln (t, wY);
    Readln (t, wZ);

    Readln (t, Vertices.X);
    Readln (t, Vertices.Y);
    Readln (t, Vertices.Z);
    Vertices.nX := wX;
    Vertices.nY := wY;
    Vertices.nZ := wZ;
    Inc (Vertices);

    Readln (t, Vertices.X);
    Readln (t, Vertices.Y);
    Readln (t, Vertices.Z);
    Vertices.nX := wX;
    Vertices.nY := wY;
    Vertices.nZ := wZ;
    Inc (Vertices);

    Readln (t, Vertices.X);
    Readln (t, Vertices.Y);
    Readln (t, Vertices.Z);
    Vertices.nX := wX;
    Vertices.nY := wY;
    Vertices.nZ := wZ;
    Inc (Vertices);
  end;
  CloseFile (t);

  Result := FD3DVB.Unlock;
end;

procedure TfrmD3D.DrawScene;
var
  i : Integer;
begin
  with FD3DDevice do begin
       SetMaterial(MaterialXWing);
       SetTransform(D3DTS_WORLD, matXWing);
       SetRenderState(D3DRS_CULLMODE, D3DCULL_CCW);
       DrawPrimitive(D3DPT_TRIANGLELIST, 0, 2498);
       SetRenderState(D3DRS_CULLMODE, D3DCULL_CW);
  end;

  for i := 0 to NumSpheres - 1 do begin
    with FD3DDevice do begin
         SetMaterial(Spheres [i].MaterialSphere);
         SetTransform(D3DTS_WORLD, Spheres [i].matSphere);
         DrawPrimitive(D3DPT_TRIANGLELIST, 7494, 110);
    end;
    with Spheres [i] do begin
         Z := Z - 0.3;
         Spheres [i].matSphere._43 := Z;
         if Z < -20 then begin
            matSphere._41 := random * 20 - 10;
            matSphere._42 := random * 20 - 10;
            Z := 50 + random (10);
            matSphere._43 := Z;
            MaterialSphere := InitMaterial(random * 0.5 + 0.5, random * 0.5 + 0.5, random * 0.5 + 0.5, 0);
         end;
    end;
  end;
end;

procedure TfrmD3D.SetupLights;
var
  Light0 : TD3DLight8;
  Light1 : TD3DLight8;
  Light2 : TD3DLight8;
begin
  Light0 := InitDirectionalLight(D3DVector(0, 0, 1), 0.3, 0.3, 0.3, 0);
  Light1 := InitDirectionalLight(VectorNormalize(D3DVector(1, 1, 1)), 0.3, 0.3, 0.3, 0);
  Light2 := InitDirectionalLight(VectorNormalize(D3DVector(1, -1, 1)), 0.3, 0.3, 0.3, 0);

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

       LightEnable(0, True);
       LightEnable(1, True);
       LightEnable(2, True);
  end;
end;

procedure TfrmD3D.ApplicationEvents1Deactivate(Sender: TObject);
begin
  FActive := False;
  Application.Minimize;
end;

procedure TfrmD3D.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Hide;
end;

function TfrmD3D.OnCreateDevice : HRESULT;
var
  hRet : HRESULT;
begin
  hRet := DirectInput8Create (hInstance, DIRECTINPUT_VERSION,
                                         IID_IDirectInput8, DInput, nil);
  if Failed (hRet) then begin
     Result := hRet;
     Exit
  end;

  hRet := DInput.CreateDevice (GUID_SysMouse, DIMouse, nil);
  if Failed (hRet) then begin
     Result := hRet;
     Exit
  end;

  hRet := DIMouse.SetDataFormat(c_dfDIMouse2);
  if Failed (hRet) then begin
     Result := hRet;
     Exit
  end;

  hRet := DIMouse.SetCooperativeLevel(Handle, DISCL_NONEXCLUSIVE or DISCL_BACKGROUND);
  if Failed (hRet) then begin
     Result := hRet;
     Exit
  end;

  Result := DIMouse.Acquire;
end;

function TfrmD3D.ReadImmediateData : HRESULT;
var
  hRet : HRESULT;
  dims2 : TDIMOUSESTATE2;
  matRotateY : TD3DMatrix;
begin
  ZeroMemory(@dims2, SizeOf(dims2));
  hRet := DIMouse.GetDeviceState(SizeOf(TDIMOUSESTATE2), @dims2);
  if Failed (hRet) then begin
     hRet := DIMouse.Acquire;
     while hRet = DIERR_INPUTLOST do hRet := DIMouse.Acquire;
  end;

  if dims2.rgbButtons[0] = 128 then begin
     SetRotateYMatrix(matRotateY, 0.1);
     matXWing := MatrixMul (matXWing, matRotateY);
  end;

  if dims2.rgbButtons[1] = 128 then begin
     SetRotateYMatrix(matRotateY, -0.1);
     matXWing := MatrixMul (matXWing, matRotateY);
  end;

  matXWing._41 := matXWing._41 + 0.01 * dims2.lX;
  matXWing._42 := matXWing._42 - 0.01 * dims2.lY;

  Result := DI_OK;
end;

end.
