Графика DirectX в Delphi

Приложение я тестировал на машине с очень скромными ресурсами. Возможно, вы получите более впечатляющую цифру. Наиболее весомый удар по скорости работы данного примера наносится фильтрацией текстуры, а усложнение игрового мира не приведет к сильному падению этого значения, до некоторой степени. Например, удаление человечков практически не сказывается на скорости работы программы. Также динамическая смена текстуры, используемая мною для стен, символизирующих выходы из сектора, не привела к заметному замедлению:

function TfrmD3D.BukupTexture (var FDSTextBMP : IDIRECT3DTEXTURE8;

const FileName : String) : HRESULT;

var

hRet : HRESULT;

d3dlr : TD3DLOCKED__RECT;

dwDstPitch : DWORD;

X, Y : DWORD;

Bmp : TBitmap;

R, G, В : 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 -I) - Y] ) ;

В := GetBValue (Bmp.Canvas.Pixels [X,

DWORD (Bmp.Height -I) - 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 := FDSTextBMP.UnlockRect(0);

end;

// Покрытие снегом текстуры

function TfrmDSD.SnowTexture (var FD3TextBMP : IDIRECT3DTEXTURE8)

HRESULT;

var

hRet : HRESULT;

d3dlr : TD3DLOCKED_RECT;

i : Integer;

dwDstPitch : DWORD;

begin

// Запираем прямоугольник текстуры

hRet := FDSTextBMP.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.OnlockRect(0);

end;

Одно из самых важных мест кода - управление игроком. Перемещения мыши изменяют его положение и угол поворота головы по горизонтали, клавиши управления курсором отвечают за положение игрока в пространстве, клавиши и ответственны за угол поворота головы по вертикали:

function TfrmD3D.ReadImmediateData : HRESULT;

var

hRet : HRESULT; dims2 : TDIMOUSESTATE2;

NewXPos, NewZPos : Single;

begin

Zero-Memory (8dims2, 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.1X <> О

// Меняем угол поворота головы по горизонтали

then RotY := RotY + 0.01 * dims2.1X; // Перемещение курсора мыши вперед-назад

if dims2.1Y > 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.1Y < 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 // Esc

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;

// Нажата клавиша "F", показывать ли значение FPS

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;