Графика DirectX в Delphi - Михаил Краснов

Sphere := (Radius * Radius) - (Scale * Scale); // Искажение

Во время перерисовки кадра накладываем фон, а искажения вносим сразу на поверхность заднего буфера:

function TfrmDD.UpdateFrame : HRESULT;

var

hRet : HRESULT;

begin

// Блиттинг фона

hRet := FDDSBack.BltFast (0, 0, FDDSBackGround, nil, DDBLTFAST_WAIT);

if Failed (hRet) then begin

Result := hRet;

Exit;

end;

hRet := Zoom; // Вызов функции создания эффекта

if Failed (hRet) then begin

Result := hRet;

Exit;

end;

Result := FlipPages; // Переключение буферов

end;

Эффект построен на простейшей математике - уравнениях круга и сферы:

function TfrmDD.Zoom : HRESULT;

var

descl : TDDSURFACEDESC2;

desc2 : TDDSURFACEDESC2;

X, Y : Integer;

XX,YY,YYXX : Integer;

mz : Single;

hRet : HRESULT;

begin

ZeroMemory (Sdescl, SizeOf(descl) );

descl.dwSize := SizeOf (descl);

ZeroMemory (@desc2, SizeOf(desc2));

desc2.dwSize := SizeOf (desc2);

hRet := FDDSBack.Lock (nil, descl, DDLOCK_WAIT, 0);

if Failed (hRet) then begin

Result := hRet;

Exit ;

end;

hRet := FDDSBackGround.Lock (nil, desc2, DDLOCK_WAIT, 0);

if Failed (hRet) then begin

Result := hRet;

Exit;

end;

for Y := -Radius to Radius do begin

YY := у * Y;

for X := -Radius to Radius do begin

XX := X * X; YYXX := YY + XX;

if YYXX < Sphere then begin // Точка внутри круга

mz := Scale / sqrt(SqrRad - YYXX); // Масштаб по третьей оси

// Пиксел на задней поверхности

PWord (Integer(descl.IpSurfасе) + (Y + mouseY) * descl.IPitch +

(mouseX + x) * 2)^ :=

// Источник на поверхности фона

PWord (Integer(desc2.IpSurfасе) +

trunc (mz * Y + mouseY) * desc2.IPitch +

trunc (mz * X + mouseX) * 2)^;

end;

end ;

end;

FDDSBackGround.Unlock (nil);

FDDSBack.Unlock (nil);

Result := DDJ3K;

end;

Для работы с устройством введены переменные уже знакомых нам типов:

DInput : IDIRECTINPUT8 = nil;

DIMouse : IDIRECTINPUTDEVICE8 = nil;

В коде подготовки устройства выполняются действия, аналогичные работе с клавиатурой, лишь поменялись константы:

function TfrmDD.OnCreateDevice : HRESULT;

var

hRet : HRESULT;

begin

hRet := DirectlnputBCreate (hlnstance, DIRECTINPUT_VERSION,

IID_IDirectInput8, DInput, nil) ;

// GUID соответствует устройству "мышь"

hRet := DInput.CreateDevice (GUID_SysMouse, DIMouse, nil);

hRet := DIMouse.SetDataFormat(c__dfDIMouse2); // Задаем формат данных

// Уровень кооперации задаем обычный

hRet := DIMouse.SetCooperativeLevel(Handle, DISCLJTONEXCLUSIVE or

DISCL__BACKGROUND) ;

Result := DIMouse.Acquire; // Захватываем устройство

end;

Опрос состояния мыши происходит непрерывно, перед каждым обновлением кадра:

procedure TfrmDD.ApplicationEventslIdle(Sender: TObject;

var Done: Boolean);

begin

if FActive then begin

ReadlmmediateData; // Ошибки игнорируем

if Failed (UpdateFrame) then RestoreAll;

end;

Done := False;

end;

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

function TfrmDD.ReadlmmediateData : HRESULT;

var

hRet : HRESULT;

dims2 : TDIMOUSESTATE2; // Структура хранения вводимых данных

begin

ZeroMemory(@dims2, SizeOf(dims2));

// Получаем сведения о состоянии мыши

hRet := DIMouse.GetDeviceState(SizeOf(TDIMOUSESTATE2), @dims2);

if Failed (hRet) then begin // Связь потеряна

hRet := DIMouse.Acquire; // Устанавливаем связь заново

while hRet = DTERR INPUTLOST do hRet := DIMouse. Acquire;

end;

// Массив rgbButtons хранит состояние дня каждой кнопки мыши

if dims2.rgbButtons[0] = 128 then begin // Нажата левая кнопка

Radius := Radius + 1; // Радиус увеличивается до некоторых пределов

if Radius > Diameter then Radius :=- Diameter;

SqrRad := Radius * Radius;

Sphere := (Radius * Radius) - (Scale * Scale);

end;

if dims2.rgbButtons[1] = 128 then begin // Нажата правая кнопка

Radius := Radius - 1; // Радиус уменьшается

if Radius < 0. then Radius := 0;

SqrRad := Radius * Radius;

Sphere := (Radius * Radius) - (Scale * Scale);

end;

// Полученное реальное приращение умножаем

mouseX := mouseX + 2 * dims2.1X;

if mouseX < Radius then mouseX := Radius else

if mouseX > ScreenWidth - Radius then mouseX := ScreenWidth - Radius;

mouseY := mouseY + 2 * dims2.1Y; if mouseY < Radius then mouseY := Radius else

if mouseY > ScreenHeight - Radius then mouseY := ScreenHeight - Radius;

Result := DI_OK;

end;

Вывод текста

Текст можно выводить двумя способами: используя функции GDI и осуществляя блиттинг растров отдельных букв. Первый способ мы применяли неоднократно в предыдущих примерах. Рассмотрим второй.

В качестве примера я приготовил простую программу изучения английского языка. Один из методов пополнения словарного запаса состоит в том, чтобы выводить на экран строки словаря на очень маленький промежуток времени, меньший 1/24 секунды. Считается, что выводимый "в 25-м кадре" текст запоминается зрителем на подсознательном уровне. Метод не требует особых усилий от обучаемого, но я не могу сказать ничего определенного по поводу его реальной эффективности, и замечу, что применяться он должен только при условии, что пользователь информирован о работе подобных программ.

Программа проекта каталога Ех08 как раз относится к разряду подобных. После ее запуска можете выполнять текущую работу и заодно обогащать свой словарный запас.

Я подготовил небольшой файл словаря, на основе которого заполняется массив строк: const

imageBmp = '..font.bmp1; // Растр шрифта

NumbLines =70; // Количество строк в файле

FileName = 'dictionary.txt'; // Файл словаря

Delay =50; // Пауза между появлениями очередной фразы

var

OutLiteral : String; // Очередная выводимая строка

StrList : Array [0..NumbLines - 1] of String; // Массив строк словаря

WinWidth, PosX : Integer; // Размеры экрана и позиция строки по X

WinHeight, PosY : Integer; // Размеры экрана и позиция строки по Y

tmpRect : TRECT; // Прямоугольник, связанный с текущей строкой

Избранные символы, с кодом большим 31, нарисованы в растре шрифта, высота каждого символа - 15 пикселов (рис. 5.8).

Используется нормальный уровень кооперации. Для создания вспомогательной поверхности определяем текущие установки экрана:

procedure TfrmDD.FormCreate(Sender: TObject);

var

hRet : HRESULT;

ddsd : TDDSurfaceDesc2;

t : TextFile;

i, maxLength : Integer;

begin

FDDSWork := nil;

FDDSGround := nil;

FDDSFont := nil;

FDDSPrimary := nil;

FDD := nil;

hRet := DirectDrawCreateEx (nil, FDD, IDirectDrawV, nil);

if Failed(hRet) then ErrorOut(hRet, 'DirectDrawCreateEx');

// Уровень кооперации - нормальный

hRet := FDD.SetCooperativeLevel(Handle, DDSCL_NORMAL);

if Failed(hRet) then ErrorOut(hRet, 'SetCooperativeLevel');

ZeroMemory(@ddsd, SizeOf(ddsd));

with ddsd do begin

dwSize := SizeOf(ddsd);

dwFlags := DDSD_CAPS;

ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE;

end;

hRet := FDD.CreateSurface(ddsd, FDDSPrimary, nil);

if Failed(hRet) then ErrorOut(hRet, 'Create Primary Surface');

// Загружаем растр со шрифтом

FDDSFont := DDLoadBitmap(FDD, imageBmp, 0, 0) ;

if FDDSFont = nil then ErrorOut(hRet, 'DDLoadBitmap');

// Узнаем текущие размеры экрана

WinWidth := GetSystemMetrics(SM_CXSCREEN);

WinHeight := GetSystemMetrics(SM_CYSCREEN);

// Поверхность для запоминания подложки выводимой фразы

ZeroMemory(@ddsd, SizeOf(ddsd));

with ddsd do begin

dwSize := SizeOf(ddsd);

dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH;

ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;

dwWidth := WinWidth;

dwHeight := WinHeight;

end;

hRet := FDD.CreateSurface(ddsd, FDDSGround, nil);

if Failed (hRet) then ErrorOut(hRet, 'CreateSurface');

// Считываем файл словаря, находим длину самой длинной фразы

AssignFile (t, FileName);

Reset (t);

maxLength := 0;

for i := 0 to NumbLines - 1 do begin

ReadLn (t, StrList [i]);

if length (StrList [i]) > maxLength then maxLength :=

length (StrList [i]);

end;

CloseFile (t);

// Поверхность для хранения растра фразы

ZeroMemory(@ddsd, SizeOf(ddsd));

with ddsd do begin

dwSize := SizeOf(ddsd);

dwFlags := DDSD__CAPS or DDSDJiEIGHT or DDSD_WIDTH;

ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;

dwWidth := maxLength * 15; // Должны вместиться все фразы

dwHeight := 15;

end;

hRet := FDD.CreateSurface(ddsd, FDDSWork, nil);

if Failed (hRet) then ErrorOut(hRet, 'CreateSurface');

Randomize;

OutLiteral := StrList [random (NumbLines)]; // Генерируем первую фразу

GeneratePos; // Случайно генерируем позицию фразы на экоане

LastTickCount := GetTickCount;

end;

Для обеспечения максимальной скорости ошибки вообще не обрабатываются. Фразы побуквенно выводятся на вспомогательную поверхность, чтобы затем на первичной поверхности отобразить всю строку целиком:

procedure TfrmDD.ApplicationEventslIdle(Sender: TObject;

var Done: Boolean);

var

rcRect : TRECT;

i, X, Y : Integer;

// Вывод одного символа на вспомогательную поверхность

procedure OutChar (ch : Char; PosX : Integer);

var

chRect : TRECT;

wrkl : integer;

begin

// В растре шрифта представлены символы, начиная с пробела

wrkl := ord (ch) - 32;

chRect.Left := wrkl rriod 16 * 15; // Прямоугольник буквы в растре шрифта

chRect.Top := wrkl div 16 * 15;

chRect.Right := chRect.Left + 15;

chRect.Bottom := chRect.Top + 15;

// Вывод буквы на вспомогательную поверхность

FDDSWork.BltFast(PosX, 0, FDDSFont, @chRect, DDBLTFAST_DONOTWAIT);

end;

begin

ThisTickCount := GetTickCount;

Done := False;

// Подошло время выводить очередную строку словаря

if (ThisTickCount - LastTickCount) < Delay then

Exit;

// Ограничивающий прямоугольник

SetRect (rcRect, PosX, PosY, PosX + length (OutLiteral) * 15, PosY + 15);

// Запоминаем, что на экране находится в этом прямоугольнике

FDDSGround.BltFast(PosX, PosY, FDDSPrimary, SrcRect, DD3LTFAST_WAIT);

// Вывод строки

FDDSPrimary.BltFast(PosX, PosY, FDDSWork, @tmpRect, DDBLTFAST WAIT);

// Запоминаем текущее положение строки

X := PosX;

Y := PosY;

OutLiteral := StrList [random (NumbLines)]; // Генерация новой строки

GeneratePos; // Генерируем позицию на экране новой строки

// Подготавливаем поверхность новой строки

for i := 1 to length (OutLiteral) do

OutChar (OutLiteral [i], (i - 1) * 15);

SetRect (tmpRect, 0, 0, length (OutLiteral) * 15, 15);

// Стираем старую фразу на экране

FDDSPrimary.BltFast(X, Y, FDDSGround, SrcRect, DDBLTFAST_WAIT);

LastTickCount := GetTickCount;

end;

Итак, фраза на экране присутствует, пока выполняется код подготовки новой строки. Это очень малый промежуток времени. Конечно, некоторые строки будут потеряны, появившись и исчезнув быстрее, чем произошло обновление экрана. Для замедления процесса можно вставить вызов системной функции sleep с небольшой задержкой, но для небыстрых компьютеров это может привести к тому, что строки начнут неприятно мерцать по всему экрану.