Пример кода на Delphi и OpenGL, показывающий интересный визуальный эффект

 

В Интернет нашёл код на Delphi + GDI (Ссылка), перевёл этот код на Delphi + OpenGL. Вышел интересный визуальный эффект. 

 

Рисунок 1. Результат работы программы

Код проекта:

unit ogl_p1_u1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, OpenGL, ExtCtrls;

type
  TForm1 = class(TForm)
    tmr1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure tmr1Timer(Sender: TObject);
    procedure FormResize(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

type
  TRGB = record
    B, G, R: Byte;
  end;

  ARGB = array[0..0] of TRGB;
  PARGB = ^ARGB;

var
  Form1: TForm1;
  MyBmp: TBitmap;
  i: Byte = 0;
  hrc: HGLRC; // Контекст OpenGL
  FHDC: HDC;  // Контекст устройства

implementation

{$R *.dfm}

const
  pfd: TPixelFormatDescriptor = (
    nSize: SizeOf(TPixelFormatDescriptor);
    nVersion: 1;
    dwFlags: PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL or PFD_DOUBLEBUFFER;
    iPixelType: PFD_TYPE_RGBA;
    cColorBits: 24;
    cDepthBits: 16;
    iLayerType: PFD_MAIN_PLANE;
  );

procedure SetupOrthoProjection;
begin
  glViewport(0, 0, Form1.ClientWidth, Form1.ClientHeight);

  glMatrixMode(GL_PROJECTION);
  glLoadIdentity;
  glOrtho(0, Form1.ClientWidth, 0, Form1.ClientHeight, -1, 1);

  glMatrixMode(GL_MODELVIEW);
  glLoadIdentity;

  glDisable(GL_DEPTH_TEST);
end;

procedure InitOpenGL;
begin
  // Настройка OpenGL
  glClearColor(0.0, 0.0, 0.0, 0.0);
  SetupOrthoProjection;
end;

procedure CreateOpenGLContext;
begin
  FHDC := GetDC(Form1.Handle); // Получаем контекст устройства
  if FHDC = 0 then
    raise Exception.Create('Не удалось получить контекст устройства.');

  // Устанавливаем формат пикселей
  if not SetPixelFormat(FHDC, ChoosePixelFormat(FHDC, @pfd), @pfd) then
    raise Exception.Create('Не удалось установить формат пикселей.');

  // Создаем контекст OpenGL
  hrc := wglCreateContext(FHDC);
  if hrc = 0 then
    raise Exception.Create('Не удалось создать контекст OpenGL.');

  // Активируем контекст OpenGL
  if not wglMakeCurrent(FHDC, hrc) then
    raise Exception.Create('Не удалось активировать контекст OpenGL.');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // Задаем фиксированные размеры для Bitmap
  MyBmp := TBitmap.Create;
  MyBmp.PixelFormat := pf24bit;
  MyBmp.Width := Form1.ClientWidth; // Фиксированная ширина
  MyBmp.Height := Form1.ClientHeight; // Фиксированная высота

  // Настраиваем таймер
  tmr1.Interval := 50;
  tmr1.Enabled := True;

  CreateOpenGLContext;
  // Инициализация OpenGL
  InitOpenGL;
end;

procedure Draw;
var
  LinePointer: PARGB;
  a, b: Real;
  x, y: Integer;
  xPos, yPos: GLfloat;
begin
  // Заполняем Bitmap данными
  for y := 0 to (MyBmp.Height - 1) do
  begin
    LinePointer := MyBmp.ScanLine[y];
    for x := 0 to (MyBmp.Width - 1) do
    begin
      a := x * x + i;
      b := y * y + i;
      LinePointer[x].R := Trunc(Abs(b));
      LinePointer[x].G := Trunc(Abs(a + b));
      LinePointer[x].B := Trunc(Abs(a));
    end;
  end;

  // Очищаем буфер и отрисовываем Bitmap
  glClear(GL_COLOR_BUFFER_BIT);

  // Вычисляем позицию для центрирования
  xPos := Abs(Form1.ClientWidth - MyBmp.Width) div 2;
  yPos := Abs(Form1.ClientHeight - MyBmp.Height) div 2;

  //glRasterPos2f(-1, -1);
  glRasterPos2f(xPos, yPos);
  glDrawPixels(MyBmp.Width, MyBmp.Height, GL_RGB, GL_UNSIGNED_BYTE, LinePointer);
  SwapBuffers(FHDC); // Обмениваем буферы
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  // Освобождаем ресурсы
  if Assigned(MyBmp) then
    MyBmp.Free;

  if hrc <> 0 then
  begin
    wglMakeCurrent(0, 0);
    wglDeleteContext(hrc);
  end;

  if FHDC <> 0 then
    ReleaseDC(Form1.Handle, FHDC);
end;

procedure TForm1.tmr1Timer(Sender: TObject);
begin
  Draw;
  Inc(i);
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  if (Form1.ClientWidth < 640) or (Form1.ClientHeight < 480) then
  begin
      MyBmp.Width := Form1.ClientWidth; // Фиксированная ширина
      MyBmp.Height := Form1.ClientHeight; // Фиксированная высота
  end
  else
  begin
      MyBmp.Width := 640; // Фиксированная ширина
      MyBmp.Height := 480; // Фиксированная высота
  end;

  SetupOrthoProjection;
end;

end.