{******************************************************************************}
{* Иллюстрация к книге "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 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;
    FD3DVBLetter    : IDIRECT3DVERTEXBUFFER8;
    FD3DVBMan       : IDIRECT3DVERTEXBUFFER8;
    FD3DTextures    : Array [0..6] of IDIRECT3DTEXTURE8;
    FD3SurfBack     : IDirect3DSurface8;
    FActive         : BOOL;
    MaterialWhite   : TD3DMaterial8;
    MaterialYellow  : TD3DMaterial8;
    MaterialRed     : TD3DMaterial8;
    MaterialGray    : TD3DMaterial8;
    MaterialBlue    : TD3DMaterial8;
    MaterialGreen   : TD3DMaterial8;
    ThisTickCount   : DWORD;
    LastTickCount   : DWORD;
    FPSThisTick     : DWORD;
    FPSLastTick     : DWORD;
    function Render : HRESULT;
    function InitD3D : HRESULT;
    function InitVB : HRESULT;
    function InitVBLetter : HRESULT;
    function InitTexture (var FD3TextBMP : IDIRECT3DTEXTURE8;
                              const FileName : String) : HRESULT;
    function BukupTexture (var FD3TextBMP : IDIRECT3DTEXTURE8;
                              const FileName : String) : HRESULT;
    function SnowTexture (var FD3TextBMP : IDIRECT3DTEXTURE8) : HRESULT;
    function OnCreateDevice : HRESULT;
    function ReadImmediateData : HRESULT;
    function TestRender (const XPos, ZPos, RotY : Single) : BOOL;
    procedure DrawScene;
    procedure DrawLetters;
    procedure DrawMan1;
    procedure DrawMan2;
    procedure DrawMan3;
    procedure MoveMan1;
    procedure MoveMan2;
    procedure MoveMan3;
    procedure InitMan;
    procedure SetupWorld;
    procedure Cleanup;
    procedure SetupLights;
    procedure ErrorOut (const Caption : PChar; const hError : HRESULT);
  public
    { Public declarations }
  end;

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

  TNormVertex = packed record
    X, Y, Z : Single;
    nX, nY, nZ : Single;
  end;

  TTriangle = record
      NumTexture : Integer;
      DIFFUSE : DWORD;
  end;

const
  D3DFVF_NORMDIFFTEXTVERTEX = D3DFVF_XYZ or D3DFVF_NORMAL or D3DFVF_DIFFUSE or D3DFVF_TEX1;
  D3DFVF_NORMVERTEX = D3DFVF_XYZ or D3DFVF_NORMAL;

  WorldFile = 'Data/World.txt';
  NumbersFile = 'Data/Numbers.txt';

  NumTriangles = 58;

{$I legoman.pas}

var
  frmD3D: TfrmD3D;

  Frames : Integer = 0;
  FpsOut : String = '';
  LetTrans : TD3DMatrix;

  TexPointer : Pointer;
  wrkTexWidth, wrkTexHeight : Integer;

  flgFPS : BOOL = True;

  Lookupdown : Single = 0.0;

  ZVector : TD3DVector;

  RotY, XPos, ZPos : Single;

  World : Array [0..NumTriangles - 1] of TTriangle;

  DInput : IDIRECTINPUT8 = nil;
  DIMouse : IDIRECTINPUTDEVICE8 = nil;
  DIKeyboard : IDirectInputDevice8;
  KeyBuffer : TDIKeyboardState;

  Angle : Single = 0.0;

  AngleFoot : Single = 0.0;
  StepFoot : Single = 0.1;

  matMan1, matWrk1, transMan1, rotMan1 : TD3DMatrix;

  transHand1, transHand2 : TD3DMatrix;
  transFoot1, transFoot2 : TD3DMatrix;

  rotLeftFootMan1, rotRightFootMan1 : TD3DMatrix;

  matLeftFootMan1, matRightFootMan1 : TD3DMatrix;

  matLeftHandMan1, matRightHandMan1 : TD3DMatrix;

  matMan2, matWrk2, transMan2, rotMan2: TD3DMatrix;

  rotLeftFootMan2, rotRightFootMan2 : TD3DMatrix;

  matLeftFootMan2, matRightFootMan2 : TD3DMatrix;

  matLeftHandMan2, matRightHandMan2 : TD3DMatrix;

  matMan3, matWrk3, transMan3, rotMan3: TD3DMatrix;

  Man3PosX : Single = 1.5;
  Man3PosZ : Single = 0.5;

  rotLeftFootMan3, rotRightFootMan3 : TD3DMatrix;

  matLeftFootMan3, matRightFootMan3 : TD3DMatrix;

  matLeftHandMan3, matRightHandMan3 : TD3DMatrix;

  TestPointX, TestPointY : DWORD;

implementation

{$R *.DFM}

procedure TfrmD3D.SetupWorld;
var
  t : TextFile;
  i, j : Integer;
  Vertices : ^TNormDiffTextVertex;
  wrkStr : String;
begin
  if FileExists(WorldFile) then begin
    AssignFile(t, WorldFile);
    try
    Reset(t);

    FD3DVB.Lock(0, NumTriangles * 3 * SizeOf(TNormDiffTextVertex), PByte(Vertices), 0);
    for i := 0 to NumTriangles - 1 do begin
      ReadLn (t, wrkStr);
      ReadLn (t, World[i].NumTexture);
      ReadLn (t, World[i].DIFFUSE);
      for j := 0 to 2 do begin
        ReadLn (t, Vertices.X, Vertices.Y, Vertices.Z,
                   Vertices.nX, Vertices.nY, Vertices.nZ,
                   Vertices.U, Vertices.V);

        Vertices.DColor := World[i].DIFFUSE;

        Inc(Vertices);
     end;
  end;

  FD3DVB.Unlock;

  except
    raise EAbort.Create ('Can''t read file: ' + WorldFile);
  end;

  CloseFile(t);
  end else raise EAbort.Create ('Can''t read file: ' + WorldFile);
end;

procedure TfrmD3D.Cleanup;
var
  i : Integer;
begin
  FreeMem (TexPointer);

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

  for i := 0 to 6 do
    if Assigned (FD3DTextures [i]) then begin
       FD3DTextures [i]._Release;
       FD3DTextures [i] := nil;
  end;

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

  if Assigned (FD3DVBMan) then begin
     FD3DVBMan._Release;
     FD3DVBMan := 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);
var
  t : TextFile;
begin
  FActive := False;
  AssignFile (t, 'Debug.txt');
  ReWrite (t);
  WriteLn (t, DXGErrorString (hError) + '    ' + Caption);
  CloseFile (t);
  Free;
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);

  TestPointX := ScreenWidth div 2;
  TestPointY := DWORD(ScreenHeight - 10);

  ZeroMemory(@d3dpp, SizeOf(d3dpp));
  with d3dpp do begin
       Windowed := False;
       Flags := D3DPRESENTFLAG_LOCKABLE_BACKBUFFER;
       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, 0,
                           1.0, 0);

  FD3DDevice.BeginScene;

  DrawScene;

  FD3DDevice.EndScene;

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

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

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

  try
    InitVBLetter;
  except
    on E : EAbort do ErrorOut (PChar(E.Message), S_FALSE);
  end;

  InitMan;

  try
    SetupWorld;
  except
    on E : EAbort do ErrorOut (PChar(E.Message), S_FALSE);
  end;

  MaterialWhite   := InitMaterial (1.0, 1.0, 1.0, 0.0);
  MaterialYellow  := InitMaterial(1, 1, 0, 0);
  MaterialRed     := InitMaterial(1, 0, 0, 0);
  MaterialGray    := InitMaterial(0.5, 0.5, 0.5, 0);
  MaterialBlue    := InitMaterial(0, 0, 1.0, 0);
  MaterialGreen   := InitMaterial(0, 1, 0, 0);

  ZVector := D3DVector(0, 1, 0);

  LetTrans := IdentityMatrix;
  LetTrans._42 := 0.5;
  LetTrans._43 := 0.9;

  transMan1 := IdentityMatrix;
  transMan2 := IdentityMatrix;
  transMan2._41 := 3.1;
  transMan3 := IdentityMatrix;
  transMan3._41 := Man3PosX;
  transMan3._43 := Man3PosZ;

  SetRotateYMatrix (wrkMat, -Pi / 2);

  SetRotateXMatrix (matWrk1, -Pi / 2);

  matWrk2 := MatrixMul (wrkMat, Matwrk1);
  matWrk3 := matWrk2;

  SetTranslateMatrix(transFoot1, 0, 0, -0.1);
  SetTranslateMatrix(transFoot2, 0, 0, 0.1);

  SetTranslateMatrix(transHand1, 0.25, 0.0, -0.2);
  SetTranslateMatrix(transHand2, -0.25, 0.0, 0.2);

  SetupLights;

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

  SetProjectionMatrix(matProj, 1, 1, 0.01, 6);
  FD3DDevice.SetTransform(D3DTS_PROJECTION, matProj);

  try
    InitTexture (FD3DTextures [0], 'data/0.bmp');
    InitTexture (FD3DTextures [1], 'data/1.bmp');
    InitTexture (FD3DTextures [2], 'data/2.bmp');
    InitTexture (FD3DTextures [3], 'data/3.bmp');
    InitTexture (FD3DTextures [4], 'data/4.bmp');
    InitTexture (FD3DTextures [5], 'data/5.bmp');
    BukupTexture (FD3DTextures [6], 'data/6.bmp');
  except
    on E : EAbort do ErrorOut (PChar(E.Message), S_FALSE);
  end;

  OnCreateDevice;
end;

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

  DIMouse.Unacquire;
  DIMouse := nil;

  DIKeyboard.Unacquire;
  DIKeyboard := nil;

  DInput := nil;
end;

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

procedure TfrmD3D.ApplicationEvents1Idle(Sender: TObject;
  var Done: Boolean);
begin
  if FActive then begin
     Inc (Frames);

     ReadImmediateData;

     Render;

     if flgFPS then begin
     FPSThisTick := GetTickCount;
     if FPSThisTick - FPSLastTick > 1000 then begin
        FpsOut := Format('%6.2f', [Frames * 1000 / (FPSThisTick - FPSLastTick)]);

        Frames := 0;

        FPSLastTick := GetTickCount;
     end;
     end;

     ThisTickCount := GetTickCount;
     if ThisTickCount - LastTickCount > 15 then begin

     SnowTexture(FD3DTextures [6]);

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

     MoveMan1;
     MoveMan2;
     MoveMan3;          

     LastTickCount := GetTickCount;
     end;
  end;

  Done := False;
end;

procedure TfrmD3D.ApplicationEvents1Restore(Sender: TObject);
var
  matProj : TD3DMatrix;
  i : Integer;
begin
  if Assigned (FD3SurfBack) then FD3SurfBack := nil;

  for i := 0 to 6 do
    if Assigned (FD3DTextures [i]) then
       FD3DTextures [i] := nil;

  if Assigned (FD3DVBLetter) then FD3DVBLetter := nil;

  if Assigned (FD3DVBMan) then FD3DVBMan := nil;

  if Assigned (FD3DVB) then FD3DVB := nil;

  WindowState := wsMaximized;

  InitD3D;

  InitVB;

  try
    InitVBLetter;
  except
    on E : EAbort do ErrorOut (PChar(E.Message), S_FALSE);
  end;

  InitMan;

  try
    SetupWorld;
  except
    on E : EAbort do ErrorOut (PChar(E.Message), S_FALSE);
  end;

  SetupLights;

  SetProjectionMatrix(matProj, 1, 1, 0.01, 6);
  FD3DDevice.SetTransform(D3DTS_PROJECTION, matProj);

  try
    InitTexture (FD3DTextures [0], 'data/0.bmp');
    InitTexture (FD3DTextures [1], 'data/1.bmp');
    InitTexture (FD3DTextures [2], 'data/2.bmp');
    InitTexture (FD3DTextures [3], 'data/3.bmp');
    InitTexture (FD3DTextures [4], 'data/4.bmp');
    InitTexture (FD3DTextures [5], 'data/5.bmp');
    BukupTexture (FD3DTextures [6], 'data/6.bmp');
  except
    on E : EAbort do ErrorOut (PChar(E.Message), S_FALSE);
  end;

  OnCreateDevice;

  FActive := True;
end;

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

function TfrmD3D.InitVB : HRESULT;
begin
  Result := FD3DDevice.CreateVertexBuffer(NumTriangles * 3 * SizeOf(TNormDiffTextVertex), 0,
                                        D3DFVF_NORMDIFFTEXTVERTEX,
                                        D3DPOOL_DEFAULT, FD3DVB);
end;

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

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

  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.InitTexture (var FD3TextBMP : IDIRECT3DTEXTURE8;
                              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;
  try
    Bmp.LoadFromfile (FileName);
  except
    raise EAbort.Create ('Can''t open file: ' + FileName);
    Result := S_FALSE;
    Exit;
  end;

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

  hRet := FD3TextBMP.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 := FD3TextBMP.UnlockRect(0);
end;

procedure TfrmD3D.DrawScene;
var
  i : Integer;
  matView : TD3DMatrix;
begin
  SetViewMatrix(matView, D3DVector(XPos, 0.25, ZPos),
                         D3DVector(XPos + cos(RotY), 0.25 + Lookupdown,
                                   ZPos - sin (RotY)), ZVector);

  with FD3DDevice do begin
       SetTransform(D3DTS_VIEW, matView);
       SetRenderState(D3DRS_CULLMODE, D3DCULL_CCW);
       SetRenderState(D3DRS_ZENABLE, D3DZB_TRUE);
       SetRenderState(D3DRS_LIGHTING, DWORD (True));
  end;

  if flgFPS then DrawLetters;

  DrawMan1;
  DrawMan2;
  DrawMan3;  

  with FD3DDevice do begin
       SetTextureStageState(0, D3DTSS_COLOROP, D3DTOP_MODULATE);
       SetTextureStageState(0,D3DTSS_MAGFILTER, D3DTEXF_LINEAR);
       SetTextureStageState(0,D3DTSS_MINFILTER, D3DTEXF_LINEAR);

       SetRenderState(D3DRS_DIFFUSEMATERIALSOURCE, D3DMCS_MATERIAL);
       SetRenderState(D3DRS_AMBIENT, $000F0F0F);

       SetMaterial(MaterialWhite);
       SetStreamSource(0, FD3DVB, SizeOf(TNormDiffTextVertex));
       SetVertexShader(D3DFVF_NORMDIFFTEXTVERTEX);
       SetTransform(D3DTS_WORLD, IdentityMatrix);
  end;

  for i := 0 to NumTriangles - 1 do with FD3DDevice do begin
      SetTexture(0, FD3DTextures[World [i].NumTexture]);
      DrawPrimitive(D3DPT_TRIANGLELIST, i * 3, 1);
  end;

  FD3DDevice.SetTexture(0, nil);
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;

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

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

  hRet := DIKeyboard.SetDataFormat(c_dfDIKeyboard);
  if Failed (hRet) then begin
     Result := hRet;
     Exit
  end;

  hRet := DIKeyboard.SetCooperativeLevel(Handle, DISCL_FOREGROUND or DISCL_EXCLUSIVE);
  if Failed (hRet) then begin
     Result := hRet;
     Exit
  end;

  Result := DIKeyboard.Acquire;
end;

function TfrmD3D.ReadImmediateData : HRESULT;
var
  hRet : HRESULT;
  dims2 : TDIMOUSESTATE2;
  NewXPos, NewZPos : Single;
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.lX <> 0 then RotY := RotY + 0.01 * dims2.lX;

  if dims2.lY > 0 then begin
     NewXPos := XPos + sin(RotY - Pi / 2) * 0.05;
     NewZPos := ZPos + cos(RotY - Pi / 2) * 0.05;

     if TestRender (NewXPos, NewZPos, RotY - Pi) then begin
        XPos := NewXPos;
        ZPos := NewZPos;
     end
  end else
  if dims2.lY < 0 then begin
     NewXPos := XPos + sin(RotY + Pi / 2) * 0.05;
     NewZPos := ZPos + cos(RotY + Pi / 2) * 0.05;

     if TestRender (NewXPos, NewZPos, RotY) then begin
        XPos := NewXPos;
        ZPos := NewZPos;
     end;
  end;

  Result := DIKeyboard.GetDeviceState(SizeOf(KeyBuffer), @KeyBuffer);

  if KeyBuffer[DIK_ESCAPE] and $80 <> 0 then begin
     Close;
     Exit;
  end;

  if KeyBuffer[DIK_RIGHT] and $80 <> 0 then begin
     XPos := XPos - sin(RotY) * 0.05;
     ZPos := ZPos - cos(RotY) * 0.05;
  end;

  if KeyBuffer[DIK_LEFT] and $80 <> 0 then begin
     XPos := XPos + sin(RotY) * 0.05;
     ZPos := ZPos + cos(RotY) * 0.05;
  end;

  if KeyBuffer[DIK_DOWN] and $80 <> 0 then begin
     XPos := XPos + sin(RotY - Pi / 2) * 0.05;
     ZPos := ZPos + cos(RotY - Pi / 2) * 0.05;
  end;

  if KeyBuffer[DIK_UP] and $80 <> 0 then begin
     XPos := XPos + sin(RotY + Pi / 2) * 0.05;
     ZPos := ZPos + cos(RotY + Pi / 2) * 0.05;
  end;

  if KeyBuffer[DIK_F] and $80 <> 0 then begin
     flgFPS := not flgFPS;
     Sleep (50);
  end;

  if KeyBuffer[DIK_PRIOR] and $80 <> 0 then begin
     Lookupdown := Lookupdown + 0.05;
     if Lookupdown > 1 then Lookupdown := 1;
  end;

  if KeyBuffer[DIK_NEXT] and $80 <> 0 then begin
     Lookupdown := Lookupdown - 0.05;
     if Lookupdown < -1 then Lookupdown := -1;
  end;
end;

procedure TfrmD3D.InitMan;
var
  i, j : Integer;
  Vertices : ^TNormVertex;
  vi : Integer;
  ni : Integer;
begin
  FD3DDevice.CreateVertexBuffer(2922 * 3 * SizeOf(TNormVertex), 0,
                                D3DFVF_NORMVERTEX,
                                D3DPOOL_DEFAULT, FD3DVBMan);

  FD3DVBMan.Lock(0, 2922 * 3 * SizeOf(TNormVertex), PByte(Vertices), 0);

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

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

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

      Inc(Vertices);
  end;

  FD3DVBMan.Unlock;
end;

function TfrmD3D.TestRender (const XPos, ZPos, RotY : Single) : BOOL;
var
  i : Integer;
  matView : TD3DMatrix;
  d3dlr : TD3DLOCKED_RECT;
  dwDstPitch : DWORD;
  DWColor : DWORD;
  B : Byte;
begin
  B := 0;

  SetViewMatrix(matView, D3DVector(XPos, 0.1, ZPos),
                         D3DVector(XPos + cos(RotY), 0.1,
                                   ZPos - sin(RotY)), ZVector);

  with FD3DDevice do begin
       Clear(0, nil, D3DCLEAR_TARGET or D3DCLEAR_ZBUFFER, $000000FF, 1.0, 0);
       BeginScene;
       SetRenderState(D3DRS_LIGHTING, DWORD (False));
       SetRenderState(D3DRS_DIFFUSEMATERIALSOURCE, D3DMCS_COLOR1);
       SetTransform(D3DTS_VIEW, matView);
       SetStreamSource(0, FD3DVB, SizeOf(TNormDiffTextVertex));
       SetVertexShader(D3DFVF_NORMDIFFTEXTVERTEX);
       SetTransform(D3DTS_WORLD, IdentityMatrix);
  end;

  for i := 0 to NumTriangles - 1 do with FD3DDevice do
      DrawPrimitive(D3DPT_TRIANGLELIST, i * 3, 1);

  with FD3DDevice do begin
       EndScene;
       GetBackBuffer (0, D3DBACKBUFFER_TYPE_MONO, FD3SurfBack);
       SetRenderState(D3DRS_LIGHTING, DWORD (True));
  end;

  FD3SurfBack.LockRect (d3dlr, nil, D3DLOCK_READONLY);

  dwDstPitch := d3dlr.Pitch;

  case FD3DfmtFullscreen of
       D3DFMT_X8R8G8B8 : begin
                         DWColor := PDWORD (DWORD(d3dlr.pBits) + TestPointY * dwDstPitch + TestPointX * 4)^;
                         B := DWColor and $1f;
                         end;
       D3DFMT_R5G6B5 : begin
                       DWColor := PDWORD (DWORD(d3dlr.pBits) + TestPointY * dwDstPitch + TestPointX * 2)^;
                       B := DWColor and $1f;
                       end;
  end;

  FD3SurfBack.UnLockRect;

  Result := not (B <> 0);
end;

function TfrmD3D.BukupTexture (var FD3TextBMP : IDIRECT3DTEXTURE8;
                               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;
  try
    Bmp.LoadFromfile (FileName);
  except
    raise EAbort.Create ('Can''t open file: ' + FileName);
    Result := S_FALSE;
    Exit;
  end;

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

  hRet := FD3TextBMP.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;

  GetMem (TexPointer, 4 * Bmp.Width * Bmp.Height);
  CopyMemory (TexPointer, d3dlr.pBits, 4 * Bmp.Width * Bmp.Height);

  wrkTexWidth := Bmp.Width;
  wrkTexHeight := Bmp.Height;

  Bmp.Free;

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

function TfrmD3D.SnowTexture (var FD3TextBMP : IDIRECT3DTEXTURE8) : HRESULT;
var
  hRet : HRESULT;
  d3dlr : TD3DLOCKED_RECT;
  i : Integer;
  dwDstPitch : DWORD;
begin
  hRet := FD3TextBMP.LockRect(0, d3dlr, nil, 0);
  if FAILED(hRet) then begin
     Result := hRet;
     Exit;
  end;

  CopyMemory (d3dlr.pBits, TexPointer, 4 * wrkTexWidth * wrkTexHeight);

  dwDstPitch := d3dlr.Pitch;

  for i := 1 to 10000 do
      PDWORD (DWORD(d3dlr.pBits) + DWORD(random(wrkTexHeight)) * dwDstPitch
              + DWORD(random(wrkTexWidth)) * 4)^ := 0;

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

const
  NumTriLetters = 729;

function TfrmD3D.InitVBLetter : HRESULT;
type
  TXY = record
    X, Y : Single;
  end;
var
  Vertices : ^TNormVertex;
  hRet : HRESULT;
  t : TextFile;
  i : Integer;
  wrk : TXY;
begin
  if FileExists(NumbersFile) then begin
  try
  AssignFile (t, NumbersFile);
  Reset (t);

  hRet := FD3DDevice.CreateVertexBuffer(NumTriLetters * SizeOf(TNormVertex), 0,
                                        D3DFVF_NORMVERTEX,
                                        D3DPOOL_DEFAULT, FD3DVBLetter);
  if Failed(hRet) then begin
     Result := hRet;
     Exit;
  end;

  hRet := FD3DVBLetter.Lock(0, NumTriLetters * SizeOf(TNormVertex), PByte(Vertices), 0);
  if Failed(hRet) then begin
     Result := hRet;
     Exit;
  end;

  for i := 1 to NumTriLetters do begin
      ReadLn (t, wrk.X, wrk.Y);
      Vertices.X := (wrk.X - 509) / 400 - 2.0;
      Vertices.Y := (wrk.Y - 205) / 400;
      Vertices.Z := 0.0;
      Vertices.nX := 0.0;
      Vertices.nY := 0.0;
      Vertices.nZ := 1.0;
      Inc(Vertices);
  end;

  CloseFile (t);

  Result := FD3DVBLetter.Unlock;

  except
    raise EAbort.Create ('Can''t open file: ' + NumbersFile);
    Result := S_FALSE;
    Exit;
  end;
  end else raise EAbort.Create ('Can''t open file: ' + NumbersFile);
end;

procedure TfrmD3D.DrawLetters;
procedure PlaceLetter (const Letter : Char; var Start, Number : Integer);
begin
  case Letter of
       '0' : begin
             Start := 0;
             Number := 23;
             end;
       '1' : begin
             Start := 69;
             Number := 17;
             end;
       '2' : begin
             Start := 120;
             Number := 22;
             end;
       '3' : begin
             Start := 186;
             Number := 34;
             end;
       '4' : begin
             Start := 288;
             Number := 12;
             end;
       '5' : begin
             Start := 324;
             Number := 23;
             end;
       '6' : begin
             Start := 393;
             Number := 30;
             end;
       '7' : begin
             Start := 483;
             Number := 9;
             end;
       '8' : begin
             Start := 510;
             Number := 40;
             end;
       '9' : begin
             Start := 630;
             Number := 27;
             end;
  ',', '.' : begin
             Start := 711;
             Number := 6;
             end;
  end;
end;
var
  i : Integer;
  nS, nW : Integer;
begin
  with FD3DDevice do begin
       SetRenderState(D3DRS_CULLMODE, D3DCULL_NONE);
       SetRenderState(D3DRS_LIGHTING, DWORD (False));
       SetStreamSource(0, FD3DVBLetter, SizeOf(TNormVertex));
       SetVertexShader(D3DFVF_NORMVERTEX);
  end;

  for i := 1 to Length(FpsOut) do begin
      PlaceLetter (FpsOut[i], nS, nW);

      LetTrans._41 := i * 0.1;
      FD3DDevice.SetTransform(D3DTS_WORLD, LetTrans);
      FD3DDevice.DrawPrimitive(D3DPT_TRIANGLELIST, nS, nW);
  end;

  with FD3DDevice do begin
       SetRenderState(D3DRS_CULLMODE, D3DCULL_CCW);
       SetRenderState(D3DRS_LIGHTING, DWORD (True));
  end;
end;

procedure TfrmD3D.MoveMan1;
begin
  SetRotateYMatrix (rotMan1, Angle + Pi);

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

  matMan1 := MatrixMul(transMan1, MatrixMul(rotMan1, matWrk1));

  AngleFoot := AngleFoot + StepFoot;
  if (AngleFoot > Pi / 4) or (AngleFoot < -Pi / 4)
     then StepFoot := -StepFoot;

  SetRotateXMatrix (rotLeftFootMan1, AngleFoot);
  SetRotateXMatrix (rotRightFootMan1, -AngleFoot);

  matLeftFootMan1 := MatrixMul(matMan1,
           MatrixMul(transFoot2,
           MatrixMul(rotLeftFootMan1, transFoot1)));

  matRightFootMan1 := MatrixMul(matMan1,
           MatrixMul(transFoot2,
           MatrixMul(rotRightFootMan1, transFoot1)));

  matLeftHandMan1 :=  MatrixMul(matMan1,
           MatrixMul(transHand2,
           MatrixMul(rotRightFootMan1, transHand1)));

  matRightHandMan1 := MatrixMul(matMan1,
           MatrixMul(transHand2,
           MatrixMul(rotLeftFootMan1, transHand1)));
end;

procedure TfrmD3D.DrawMan1;
begin
  with FD3DDevice do begin
       SetStreamSource(0, FD3DVBMan, SizeOf(TNormVertex));
       SetVertexShader(D3DFVF_NORMVERTEX);
       LightEnable(2, False);
 end;

  with FD3DDevice do begin
    SetMaterial(MaterialGray);

    SetTransform(D3DTS_WORLD, matLeftFootMan1);
    DrawPrimitive(D3DPT_TRIANGLELIST, 0, 112); 

    SetTransform(D3DTS_WORLD, matRightFootMan1);
    DrawPrimitive(D3DPT_TRIANGLELIST, 948, 112);

    SetMaterial(MaterialRed);
    SetTransform(D3DTS_WORLD, matLeftHandMan1);
    DrawPrimitive(D3DPT_TRIANGLELIST, 4986, 612);

    SetMaterial(MaterialYellow);
    DrawPrimitive(D3DPT_TRIANGLELIST, 6822, 324);

    SetMaterial(MaterialRed);
    SetTransform(D3DTS_WORLD, matRightHandMan1);
    DrawPrimitive(D3DPT_TRIANGLELIST, 3144, 614);

    SetMaterial(MaterialYellow);
    DrawPrimitive(D3DPT_TRIANGLELIST, 7794, 324);

    SetTransform(D3DTS_WORLD, matMan1);
    DrawPrimitive(D3DPT_TRIANGLELIST, 1284, 620);

    SetMaterial(MaterialRed);
    DrawPrimitive(D3DPT_TRIANGLELIST, 336, 204);
  end;
end;

procedure TfrmD3D.MoveMan2;
begin
  transMan2._41 := transMan2._41 - 0.01;
  if transMan2._41 < -3.1 then transMan2._41 := 3.1;

  matMan2 := MatrixMul(transMan2, matWrk2);

  AngleFoot := AngleFoot + StepFoot;
  if (AngleFoot > Pi / 4) or (AngleFoot < -Pi / 4)
     then StepFoot := -StepFoot;

  SetRotateXMatrix (rotLeftFootMan2, AngleFoot);
  SetRotateXMatrix (rotRightFootMan2, -AngleFoot);

  matLeftFootMan2 := MatrixMul(matMan2,
           MatrixMul(transFoot2,
           MatrixMul(rotLeftFootMan2, transFoot1)));

  matRightFootMan2 := MatrixMul(matMan2,
           MatrixMul(transFoot2,
           MatrixMul(rotRightFootMan2, transFoot1)));

  matLeftHandMan2 :=  MatrixMul(matMan2,
           MatrixMul(transHand2,
           MatrixMul(rotRightFootMan2, transHand1)));

  matRightHandMan2 := MatrixMul(matMan2,
           MatrixMul(transHand2,
           MatrixMul(rotLeftFootMan2, transHand1)));
end;

procedure TfrmD3D.DrawMan2;
begin
  with FD3DDevice do begin
    SetMaterial(MaterialGray);

    SetTransform(D3DTS_WORLD, matLeftFootMan2);
    DrawPrimitive(D3DPT_TRIANGLELIST, 0, 112);

    SetTransform(D3DTS_WORLD, matRightFootMan2);
    DrawPrimitive(D3DPT_TRIANGLELIST, 948, 112);

    SetMaterial(MaterialBlue);
    SetTransform(D3DTS_WORLD, matLeftHandMan2);
    DrawPrimitive(D3DPT_TRIANGLELIST, 4986, 612);

    SetMaterial(MaterialYellow);
    DrawPrimitive(D3DPT_TRIANGLELIST, 6822, 324);

    SetMaterial(MaterialBlue);
    SetTransform(D3DTS_WORLD, matRightHandMan2);
    DrawPrimitive(D3DPT_TRIANGLELIST, 3144, 614);

    SetMaterial(MaterialYellow);
    DrawPrimitive(D3DPT_TRIANGLELIST, 7794, 324);

    SetTransform(D3DTS_WORLD, matMan2);
    DrawPrimitive(D3DPT_TRIANGLELIST, 1284, 620);

    SetMaterial(MaterialBlue);
    DrawPrimitive(D3DPT_TRIANGLELIST, 336, 204);
  end;
end;

procedure TfrmD3D.MoveMan3;
var
  wrkAngle : Single;
  distX, distZ : Single;
begin
  distX := XPos - Man3PosX;
  distZ := ZPos - Man3PosZ;

  if distZ < 0
     then wrkAngle := arctan (distX / distZ) - Pi / 2
     else wrkAngle := arctan (distX / distZ) + Pi / 2;

  SetRotateYMatrix (rotMan3, wrkAngle);

  if (abs(distX) > 0.02) and (abs (distZ) > 0.02) then begin
     Man3PosX := Man3PosX + distX / 20;
     Man3PosZ := Man3PosZ + distZ / 20;

     transMan3._41 := Man3PosX;
     transMan3._43 := Man3PosZ;

  end;

  matMan3 := MatrixMul(transMan3, MatrixMul(rotMan3, matWrk2));

  AngleFoot := AngleFoot + StepFoot;
  if (AngleFoot > Pi / 4) or (AngleFoot < -Pi / 4)
     then StepFoot := -StepFoot;

  SetRotateXMatrix (rotLeftFootMan3, AngleFoot);
  SetRotateXMatrix (rotRightFootMan3, -AngleFoot);

  matLeftFootMan3 := MatrixMul(matMan3,
           MatrixMul(transFoot2,
           MatrixMul(rotLeftFootMan3, transFoot1)));

  matRightFootMan3 := MatrixMul(matMan3,
           MatrixMul(transFoot2,
           MatrixMul(rotRightFootMan3, transFoot1)));

  matLeftHandMan3 :=  MatrixMul(matMan3,
           MatrixMul(transHand2,
           MatrixMul(rotRightFootMan3, transHand1)));

  matRightHandMan3 := MatrixMul(matMan3,
           MatrixMul(transHand2,
           MatrixMul(rotLeftFootMan3, transHand1)));
end;

procedure TfrmD3D.DrawMan3;
begin
  with FD3DDevice do begin
    SetMaterial(MaterialGray);

    SetTransform(D3DTS_WORLD, matLeftFootMan3);
    DrawPrimitive(D3DPT_TRIANGLELIST, 0, 112);

    SetTransform(D3DTS_WORLD, matRightFootMan3);
    DrawPrimitive(D3DPT_TRIANGLELIST, 948, 112);

    SetMaterial(MaterialGreen);
    SetTransform(D3DTS_WORLD, matLeftHandMan3);
    DrawPrimitive(D3DPT_TRIANGLELIST, 4986, 612);

    SetMaterial(MaterialYellow);
    DrawPrimitive(D3DPT_TRIANGLELIST, 6822, 324);

    SetMaterial(MaterialGreen);
    SetTransform(D3DTS_WORLD, matRightHandMan3);
    DrawPrimitive(D3DPT_TRIANGLELIST, 3144, 614);

    SetMaterial(MaterialYellow);
    DrawPrimitive(D3DPT_TRIANGLELIST, 7794, 324);

    SetTransform(D3DTS_WORLD, matMan3);
    DrawPrimitive(D3DPT_TRIANGLELIST, 1284, 620);

    SetMaterial(MaterialGreen);
    DrawPrimitive(D3DPT_TRIANGLELIST, 336, 204);
    LightEnable(2, True);
  end;
end;

end.

