Создание в Delphi эффекта пламени c использованием DirectX

 Существует мнение, что демки необходимо делать на ассемблере или, в крайнем случае, на Си. Якобы, хорошая демо должна иметь маленький размер, чего нельзя добиться в Delphi или Visual Basic . На самом деле, это не так. Главное в демке ни размер, ни алгоритмы, ни язык, на котором она написана, а выполняемые ей действия.

В этой статье я опишу графический эффект, который, наверное, делали все демо-дизайнеры – эффект пламени. Создавать его будем в Delphi с использованием DirectX и WinAPI.

Итак, начнем. Первое, что необходимо сделать – это создать в Delphi новой проект (Меню: File/New/Application). Так как мы не будем использовать VCL , то удалим из проекта форму (Project/Remove from Project). Откроем файл проекта (Project/View Source) и перепишем его:

program Project1;

uses
  windows,messages,directdraw;

{$R *.res}

type tacc=array[0..307200] of byte;


var
    WindowClass: TWndClass; 
    Instance: HWnd;
    Handle: HWnd; 
    msg: TMsg; 
    DDResult : HResult;
    DDrawObject : IDirectDraw;
    PrimarySurface : IDirectDrawSurface; 
    SecondarySurface : IDirectDrawSurface;  
    DDPal: IDirectDrawPalette;
    SurfaceDescription: TDDSurfaceDesc;  
    BackCaps: TDDSCaps;  
    palen:array[0..255] of PaletteEntry;  
    b1,b2:^tacc;

begin
  InitApp;
  InitDirectDraw; 
  while GetMessage( msg, 0, 0, 0) do
  begin
    translatemessage(msg);
    dispatchmessage(msg);
  end;
end.

В секции uses мы прописали directdraw. Этот модуль для работы с библиотекой DirectDraw, которого нет в стандартной поставке Delphi. Я использую адаптацию C++ заголовков, сделанную Erik Unger. Затем идет описание глобальных переменных, необходимых в работе программы.
В основной части программы вызываются процедуры: InitApp - для создание окна, и InitDirectDraw - для инициализации DirectDraw. Далее идет цикл заставляющий обрабатывать сообщения окна.

Первое, что должна делать программа – это создать окно в Windows.

procedure InitApp;
begin
  instance := GetModuleHandle(nil);
  with WindowClass do
  begin
    style := CS_HRedraw or CS_VRedraw;
    lpfnWndProc := @windowproc;
    Hinstance := Instance;
    LpszClassName := 'DXF';
    hbrBackground:=0;
    hIcon := 0;
  end;
  RegisterClass(WindowClass);
  Handle:=CreateWindowEx(0, 'DXF', 'Flame', WS_POPUP,
      5, 5, GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN),
      0, 0, instance, nil);
  UpdateWindow(Handle);
  ShowWindow(Handle, CmdShow);
  SetTimer(Handle, 1, 1, nil);
end;

Сначала, мы заполняем структуру WindowsClass, необходимую для регистрации класса окна. Затем, с помощью RegisterClass, регистрируем класс в Windows. После этого, создаем окно и выводим его на экран.
В конце процедуры мы создадим таймер срабатывающий каждую миллисекунду.

При регистрации класса окна мы указали, что процедура windowproc будет обрабатывать все события поступающие окну.

function windowproc (Hwn,msg,wpr,lpr: longint): longint; stdcall;
begin
  result := defwindowproc(hwn,msg,wpr,lpr);
  case msg of
    WM_DESTROY:
    begin
       FreeAll;
      Halt;
    end;

    WM_SETCURSOR:
      SetCursor(0);

    WM_KEYDOWN:
    begin
      if wpr=VK_ESCAPE then  begin  
        FreeAll;                   
        Halt;
       end;
    end;

    WM_TIMER:
      redraw;
  end;
end;

При получении сообщения WM_DESTROY или нажатии кнопки Esc программа вызывает FreeAll, отвечающею за освобождение системных ресурсов, занятых нами, и завершает работу. При сообщении WM_TIMER, вызывается процедура redraw, выполняющая вывод очередного кадра на экран.

Но перед тем, как выводить что-либо на экран нужно инициализировать DirectDraw, и создать необходимые поверхности и буферы, а также установить палитру.

procedure InitDirectDraw;
var I: Integer;
begin
  DDResult := DirectDrawCreate (nil, DDrawObject, nil);
  DDResult := DDrawObject.SetCooperativeLevel(handle, DDSCL_EXCLUSIVE or DDSCL_FULLSCREEN);
  DDResult := DDrawObject.SetDisplayMode(640, 480, 8);

  with SurfaceDescription do
  begin
    dwSize := sizeof(SurfaceDescription);
    dwFlags := DDSD_CAPS or DDSD_BACKBUFFERCOUNT;
    ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE or DDSCAPS_FLIP or DDSCAPS_COMPLEX;
    DwBackBufferCount := 1;
  end;
  DDResult := DDrawObject.CreateSurface (SurfaceDescription,PrimarySurface,nil);

  BackCaps.dwCaps := DDSCAPS_BACKBUFFER;
  PrimarySurface.GetAttachedSurface(BackCaps, SecondarySurface);

  for i:=0 to 25 do              
  begin
    palen[i].peRed := (i)*10;
    palen[i].peGreen := 0;
    palen[i].peBlue := 0;
  end;
  for i:=26 to 85 do      
  begin
    palen[i].peRed := 255;
    palen[i].peGreen := round((i-25)*4.2);
    palen[i].peBlue := 0;
  end;
  for i := 86 to 141 do         
  begin
    palen[i].peRed := 255;
    palen[i].peGreen := 255;
    palen[i].peBlue := round((i-86)*4.51);
  end;
  for i := 142 to 255 do     
  begin
    palen[i].peRed := 255;
    palen[i].peGreen := 255;
    palen[i].peBlue := 255;
  end;
  DDrawObject.CreatePalette(DDPCAPS_8BIT or DDPCAPS_ALLOW256, @palen, DDPal, nil);
  PrimarySurface.SetPalette(DDPal);

  new(b1);
  new(b2);
end; 

Во-первых, создаем объект DirectDraw. Устанавливаем приложению эксклюзивный полноэкранный уровень и разрешения экрана 640x480x8.
Во-вторых, создадим первичную и вторичную поверхности.
Эффект пламени проще и быстрей реализовать используя палитровые поверхности, поэтому создадим палитру с плавным переходом цветов: черный – красный – желтый – белый.
Последнее, что необходимо сделать – это создать два буфера для генерации пламени: b1 и b2.

Теперь можно рассмотреть и генерацию кадров.

procedure redraw;

var i, j, k: Integer;
    swp: Pointer;
    diracc:^tacc;

begin
  i := 0;
  while (i<640) do
  begin
    b1[i+0] := random(2)*255;
    b1[i+640] := random(2)*255;
    inc(i, random(5));
  end;

  for i := 1280 to 307200 do
    b2[i] := ((b1[i-1]+b1[i+1]+b1[i]+b1[i-639]+b1[i-641]+b1[i-1279]+b1[i-1280]+b1[i-1281]) shr 3);

  try
    SecondarySurface.Lock(nil, SurfaceDescription, DDLOCK_SURFACEMEMORYPTR or DDLOCK_WRITEONLY or DDLOCK_WAIT, 0);
    diracc := SurfaceDescription.lpSurface;
    j := 0;
    k := 306560;
    for i := 0 to 477 do
    begin
      Move(b2[k], diracc[j], 640);
      inc(j, SurfaceDescription.lPitch);
      dec(k, 640);
    end;
  finally
    SecondarySurface.Unlock(nil);
  end;

  swp := b1;
  b1 := b2;
  b2 := swp;

  PrimarySurface.Flip(nil, DDFLIP_WAIT);
end;

Первый цикл – это создание так называемых "hotspots", случайных точек максимального цвета в начале первого буфера.
Алгоритм, используемый мной, заключается в том, что я ставлю точку во второй буфер равною среднее значение суммы точек первого буфера, которые окружаю точку находящейся выше на линию данной (Y координата меньше на 1). Эти и занимается второй цикл.
Далее все просто. Лочим вторичную поверхность, для прямого доступа к ее памяти. Копируем на нее содержимое второго буфера (только в зеркальном отражении по оси X, иначе гореть будет сверху вниз).Меняем местами b1 и b2, а также первичную и вторичную поверхности. И кадр выведен на экран.

Последнее, что необходимо написать - это освобождение системных ресурсов перед выходом из программы.

procedure FreeAll;
begin
  Dispose(b2);
  Dispose(b1);
  DDPal._Release;
  pointer(DDPal) := nil;
  SecondarySurface._Release;
  pointer(SecondarySurface) := nil;
  PrimarySurface._Release;
  pointer(PrimarySurface) := nil;
  DDrawObject._Release;
  pointer(DDrawObject) := nil;

end;