Быстрая отрисовка

[Mavlyudov]

Есть такой вопрос: существуют ли альтернативы SetPixel для более быстрого вывода пиксела?
Нашел недавно проект на VB, перевел его на Delphi (можно использовать и в Free Pascal, если создавать контент отрисовки на WinApi).
Там используется функция SetDIBitsToDevice из
библиотеки gdi32.dll.
На VB работает, на Delphi нет. Есть у кого возможность посмотреть?

[runewalsh]

А у меня она работает, только что проверил. Ты правильно её вызываешь? Ты проверяешь код ошибки? А может быть, ты делаешь это не в FormPaint? (хотя поначалу сработать не из FormPaint всё равно должно, просто сотрётся, когда форма захочет перерисоваться — например, после alt-tab.)

Альтернативы — рисовать в памяти и копировать на канву формы через TCanvas.Draw, TCanvas.CopyRect: https://stackoverflow.com/a/16217886.

[Mavlyudov]

А у тебя какой код? Покажи.

Про альтернативу я имел ввиду без привязки к форме. Если написана программа на WinApi

[runewalsh]

Хм, проверил собственный совет с FormPaint — всё-таки моргает, подозреваю, ей не получится нормально рисовать. Но про моргание вопроса не было ^^
Первая половина — генерация картинки, смысловая нагрузка начинается с FillChar.

Код: Выделить всё

procedure TMainForm.FormClick(Sender: TObject);
var
   bitmap: array of array[0 .. 3] of uint8;
   w, h, x, y, border: SizeInt;
   nx, ny, d, awx, awy: single;
   bi: BITMAPINFO;
   dc: HDC;
begin
   border := 10;
   w := Width - 2 * border;
   h := Height - 2 * border;
   if (w <= 0) or (h <= 0) then exit;

   SetLength(bitmap, w*h);
   for y := 0 to h-1 do
      for x := 0 to w-1 do
      begin
         nx := 2 * (x/w - 0.5) * (w / (0.5 * (w + h)));
         ny := 2 * (y/h - 0.5) * (h / (0.5 * (w + h)));
         d := sqrt(sqr(nx) + sqr(ny));
         awx := d * cos(20 * d);
         awy := d * sin(20 * d);
         bitmap[y*w+x][2] := round(255 * Math.EnsureRange(1 - sqrt(sqr(awx - nx) + sqr(awy - ny)) / (d + 1e-9), 0, 1));
      end;

   fillchar((@bi)^, sizeof(bi), 0);
   bi.bmiHeader.biSize := sizeof(bi.bmiHeader);
   bi.bmiHeader.biWidth := w;
   bi.bmiHeader.biHeight := h;
   bi.bmiHeader.biPlanes := 1;
   bi.bmiHeader.biBitCount := bitsizeof(bitmap[0]);
   bi.bmiHeader.biCompression := BI_RGB;

   dc := GetDC(Handle);
   if dc = 0 then raise Exception.CreateFmt('GetDC: %s', [SysErrorMessage(GetLastError)]);
   try
      if SetDIBitsToDevice(dc, {x} border, {y} border, w, h, 0, 0, 0, h, pointer(bitmap), bi, DIB_RGB_COLORS) = 0then
         raise Exception.CreateFmt('SetDIBitsToDevice: %s', [SysErrorMessage(GetLastError)]);
   finally
      ReleaseDC(Handle, dc);
   end;
end;

setdibitstodevice.png

Вообще странная какая-то штуковина, мне не нравится. Если уж хочешь WinAPI, погугли в сторону внеэкранного DC и BitBlt с него на окно.

[Mavlyudov]

Вот мой код. При нажатии на кнопку ничего не происходит.

Код: Выделить всё

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

procedure GFX_SET_PIXEL_DIB(var obj : array of byte; sX : longint;sY : longint;zColor : longint;hWidth : longint);
procedure draw(DC:HDC);

implementation

{$R *.dfm}

function SetDIBitsToDevice(hdc : longint;x : longint;y : longint;dx : longint;dy : longint;SrcX : longint;SrcY : longint;Scan : longint; NumScans : longint;Bits : variant;BitsInfo : TBITMAPINFO;wUsage : longint) : longint; stdcall ;external 'gdi32';

procedure draw(DC:HDC);
var
bBytes : array of byte;
bi24BitInfo : TBITMAPINFO;
Cnt : longint;
xc : integer;
yc : integer;

begin

with bi24BitInfo.bmiHeader do begin
biBitCount := 24;
biCompression := BI_RGB;
biPlanes := 1;
biSize := 40;
biWidth := 608;
biHeight := 608;
end;

setlength(bBytes, bi24BitInfo.bmiHeader.biWidth * bi24BitInfo.bmiHeader.biHeight * 3 + 1 );
for yc := 0 to 607 do begin
for xc := 0 to 607 do begin
GFX_SET_PIXEL_DIB(bBytes , xc , yc , clRed , bi24BitInfo.bmiHeader.biWidth );
end;
end;

SetDIBitsToDevice(DC,0,0, bi24BitInfo.bmiHeader.biWidth ,
      bi24BitInfo.bmiHeader.biHeight ,0,0,0, bi24BitInfo.bmiHeader.biHeight ,
      bBytes[1],
      bi24BitInfo, DIB_RGB_COLORS );
end;

procedure GFX_SET_PIXEL_DIB(var obj : array of byte;sX : longint;sY : longint;zColor : longint;hWidth : longint);

var
B : byte;
cNum : longint;
dibX : longint;
dibY : longint;
G : byte;
R : byte;
begin
dibX := sX+1;
dibY := hWidth-sY;
cNum := ( hWidth *( dibY-1)+dibX)* 3-2;
R := zColor div 65536;
G := ( zColor And 65535) div 256;
B := zColor And 255;
obj[ cNum ] := R;
obj [ cNum+2 ] := B;
obj[ cNum+1 ] := G;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Draw(Form1.Canvas.Handle);
end;

end.

[runewalsh]

С дуба рухнул, какой ещё variant?! :D (извиняюсь) (у меня падает, кстати).
Плюс, BITMAPINFO передаётся по значению, а должен по ссылке...
Передача по var и по значению бинарно несовместимы. Pointer и не-pointer — тоже. В импортируемых функциях важно, чтобы передавались правильные параметры в правильном порядке, причём компилятор этого проверить не сможет.
Правильная сигнатура:

Код: Выделить всё

function SetDIBitsToDevice(hdc: HDC; XDest, YDest: integer; dwWidth, dwHeight: DWORD; srcX, srcY: integer; uStartScan, cScanLines: UINT; lpvBits: pointer; var lpbmi: BITMAPINFO; fuColorUse: UINT): integer; stdcall; external gdi32;

А вообще эта функция должна быть определена в модуле Windows, объявление было не только неправильным, но и лишним.

[Mavlyudov]

Согласен по поводу того, что она уже объявлена в windows.
Теперь не вызывается. Ошибка
на аргументе функции SetDIBitsToDevice:

bBytes[1]

Incompatible types: 'Byte' and 'Pointer'

[runewalsh]

Тебе знакомо понятие указателя и оператор взятия адреса?

[Mavlyudov]

Да,

Код: Выделить всё

@bBytes[1]

А как можно эту функцию исползовать, чтобы сделать аналог SetPixel(DC: HDC; X, Y: Integer; Color: COLORREF): COLORREF; ?

[runewalsh]

Можно было бы интерпретировать переменную COLORREF как картинку 1×1, но, правда, её 4 байта хранятся в памяти (в предположении Little-Endian) как RGBX (например, clRed = $0000FF ⇒ FF, 00, 00, 00, clSkyBlue = $F0CAA6 ⇒ A6, CA, F0, 00), а SetDIBitsToDevice ожидает BGR, так что если просто взять и передать, каналы R и B обменяются. Ну и ты же понимаешь, что это будет ещё медленнее, чем SetPixel...

[Mavlyudov]

Даже если медленнее, то хотя бы попробовать.
А как правильно переделать? Вот есть такая функция

[Alex2013]

Доступ к пикселям на битмапе можно делать так :

Код: Выделить всё

Function InR(AA,B,C:Longint):Boolean;
begin
InR:=((AA>=B) And (AA<=C));
End;

// Только 24 Бита !
Procedure Set_Pixel(Var BB:TBitmap;X,Y,C:Integer);
Type
TA=Array[0..1] of byte;
var
 PA:^TA;
 n:integer;
begin
if bb = NIL then exit;
 if not InR(x,0,bb.Width-1) then exit;
 if not InR(y,0,bb.Height-1) then exit;

Bb.BeginUpdate; ;
 pa:=Pointer(BB.RawImage.Data);
 N:=Y*(BB.Width*3)+X*3;
pa^[n]  :=Blue(C);
pa^[n+1]:=Green(C);
pa^[n+2]:=red(C);
Bb.EndUpdate;
end;
// Только 24 Бита !
Function Get_Pixel(var BB:TBitmap;X,Y:Integer):Integer;
Type
TA=Array[0..1] of byte;
Var
 PA:^TA;
  n:integer;
begin
 Get_Pixel:=-1;
  if bb = NIL then exit;
  if not InR(x,0,bb.Width-1) then exit;
  if not InR(y,0,bb.Height-1) then exit;
 pa:=Pointer(BB.RawImage.Data);
 N:=Y*(BB.Width*3)+X*3;
 Get_Pixel:=rgb(pa^[n+2],pa^[n+1],pa^[n]);
end;

Логика работы простая:
Создаешь Tbitmap ->рисуешь что надо-> потом выводишь например через canvas.Draw куда нужно .-> освобождаешь Tbitmap .

Зы
Вот моя библиотечка для более менее быстрой 2д-графики ...
https://yadi.sk/d/KkNUAVPn3UqSG3
(Писал для внутреннего использования по этому все в кучу и почти без комментариев, Canny-фильтр тормоз (нужно капитально оптимизировать )
в основном работает только т в 24-х битном режиме ... но можно по посмотреть как пример простой реализации элементарных 2д-фильтров )

[Mavlyudov]

А можно как-то либо предыдущую функцию, либо Вашу функцию использовать там, где раньше использовалась SetPixel?
К примеру, сделать универсальную процедуру, куда можно устанавливать разные способы отрисовок.
Скажем, через WinApi вот так:

Код: Выделить всё

PROCEDURE OUTPIXEL(IX,IY:INTEGER;IC : TCOLORREF);
BEGIN
SETPIXEL(DC,IX,IY,IC);
END;

[Alex2013]

Смысла нет ... через дисплейный контекст чуть универсальние ... но огромный тормоз по умолчанию.
А если скорость СОВСЕМ неважна делай через Canvas.Pixels[X,Y] := C; (Возни меньше)
Доступ к битмапу как к обычной памяти (например как это сделано у меня )по умолчанию самый быстрый но работа с отдельными писклями используется редко . Для блочной обработки и создания спрайтов самый быстрый вариант пересылка через BitBlt и StretchBlt (там еще и логические операции в ассортименте : And Not Xor Or и т.д. )

[Mavlyudov]

Через Pixels не вариант. Пишу на WinApi. Хочу сделать аналог setpixel, а через него и lineto.