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

[Mavlyudov]

Pavia

Показывайте код. Целиком выложите проект

Вот код через OpenGL

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

unit Unit1;

interface

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

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

var
  Form1: TForm1;
  dc:hdc;
//  hrc:HGLRC;
BitMap : TBitMap;


implementation

{$R *.dfm}
procedure SetDCPixelFormat (hdc : HDC);
var
pfd : TPixelFormatDescriptor;
nPixelFormat : Integer;
begin
//FillChar(pfd, SizeOf (pfd), 0);
pfd.dwFlags := PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL or PFD_DOUBLEBUFFER;
nPixelFormat :=ChoosePixelFormat (hdc, @pfd);
SetPixelFormat(hdc, nPixelFormat, @pfd);
wglMakeCurrent(hDC, wglCreateContext(hDC));
end;

procedure MakeDC(DC:HWND);
begin
SetDCPixelFormat(DC);

glViewport(0,0,form1.ClientWidth,form1.ClientHeight);
glMatrixMode(GL_PROJECTION);
glLoadIdentity;
glOrtho( 0, form1.ClientWidth,form1.ClientHeight,0, -1, 1 );
glMatrixMode(GL_MODELVIEW);
glLoadIdentity;
end;


procedure TForm1.FormCreate(Sender: TObject);
begin
Form1.Width:=1024;
Form1.Height:=768;
DC:=GetDC(Handle);
MakeDC(DC);
end;


procedure TForm1.FormDestroy(Sender: TObject);
begin
wglMakeCurrent(0, 0);
//wglDeleteContext(hrc);
ReleaseDC(Handle, DC);
DeleteDC(DC);
end;

procedure WritePoint(DC:HDC; x,y:integer;ic:TColorREF);
var
r,g,b:DWORD;
begin
r:=GetRValue(ic);
g:=GetGValue(ic);
b:=GetBValue(ic);
glPointSize(1);
glColor3f(r,g,b);
glBegin(GL_POINTS);
glVertex2f(x,y);
glEnd;
end;


procedure TForm1.Button1Click(Sender: TObject);
var
i,j,t:integer;
begin
t:=GetTickCount;
for i:=0 to form1.ClientWidth do begin
for j:=0 to form1.ClientHeight do begin
WritePoint(DC,i,j,clred);
end;
end;
t:=GetTickCount-t;
Form1.Caption :=IntToStr(t)+' ms';
SwapBuffers(DC);
end;
end.

Теперь вопрос про отрисовку через SetDIBitsToDevice

Alex2013

Зачем вообще на точках зацикливаться ?

Потому что хочется перекомпилировать одну программу, в которой используется SetPixel, но чтобы можно было отрисовку делать универсальной,
используется

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

Type MyPixel=procedure(DC:HDC;x,y:integer;ic:TColorRef);
var
  PPutPixel:MyPixel;


Впрочем, полный код ниже.
вопрос: как правильно вынести отрисовку отдельно, а не для каждого пиксела?
Верно ли задавать размерность массива wth:=1; hth:=1; SetLength(bBytes, wth*hth)? Или надо по размеру изображения

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

unit Unit1;

interface

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

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

Type MyPixel=procedure(DC:HDC;x,y:integer;ic:TColorRef);

var
  Form1: TForm1;
  PPutPixel:MyPixel;
  fwth,fhth:integer;
  DC:HDC;

implementation

{$R *.dfm}

procedure draw3(DC:HDC;x,y:integer;ic:TColorRef);
var
   bBytes: array of longint;
   yc, xc: Longint;
   bi: BITMAPINFO;
  wth,hth:integer;
begin
wth:=1; hth:=1;
   with bi.bmiHeader do begin
      biSize := sizeof(bi);
      biBitCount := 32;
      biCompression := BI_RGB;
      biPlanes := 1;
      biWidth := wth;
      biHeight := hth;
   end;

  SetLength(bBytes, wth*hth);
   for xc:=Low(bBytes) to High(bBytes) do begin
      bBytes[xc] :=clBlue;
   end; // xc
   SetDIBitsToDevice
     (dc,
      x,
      y,
      bi.bmiHeader.biWidth,
      bi.bmiHeader.biHeight,
      0, 0, 0,
      bi.bmiHeader.biHeight,
      @bBytes[0],
      bi, DIB_RGB_COLORS);
end;

procedure TForm1.Button1Click(Sender: TObject);
var i,j:integer;
begin
DC:=GetDC(Form1.Handle);
PPutPixel:=Draw3;
for i:=0 to fwth-1 do begin
for j:=0 to fhth-1 do begin
PPutPixel(DC,i,j,clred);
end;
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
fwth:=form1.Width;
fhth:=form1.Height;
end;

end.


[Alex2013]

[

Alex2013

Зачем вообще на точках зацикливаться ?

Потому что хочется перекомпилировать одну программу, в которой используется SetPixel, но чтобы можно было отрисовку делать универсальной,
используется

Если там ТОЛЬКО вывод точек (точечный график неких случайных величин ) то возможно смысл есть ...
Но если дело обстоит иначе то тут уже моя очередь делать "рука лицо pcx" ... если я правильно понял то далее в проекте будут как минимум линии, а возможно другие примитивы.
Вопрос, что мешает сделать их рисование как прямой вызов соответствующих процедур из API вместо того что-бы пытаться "медленно и печально " строить тоже самое ПО ТОЧКА ?
Зы
Я тут сам наверное буду пытаться создать некий "нулевой слой" для своих проектов но основой там точно будет нормальный набор примитивов : линии ,круги, полигоны, эллипсы,прямоугольники... и т.п. а точки если будут то "на всякий пожарный " а не как основа . Еще раз повторяю разница в реализации рисования готового примитива и доступа к пикселю может быть ЧУДОВИЩНАЯ . (Может действительно получится как сказа Zub "Эпическое сражение" класса "карьерный экскаватор" против "детского совочка " ) То есть, каким бы умным алгоритмом не рисовать по точкам и каким бы методом доступа к пикселю не пользоваться, никто не получит равной эффективность с качественными алгоритмами и/или аппаратным ускорением методов изначально заточенных на рисование примитивов целиком, а не по точкам .... Что кстати отлично показал Zub ! Причем там есть не слабые резервы, что видно по использованию вроде как "чисто софтварной " библиотеки OpenCV .
Зы Зы
За наглядностью ходить далеко не надо ! Вон у тебя закраска формы в "два цикла " а если просто цвет поменять ?(form1.color:=Rgb(Random( 255),Random( 255),Random( 255)); ) там скорее всего даже измерить время этой операции нормально (точнее "честно") не получиться, настолько быстро и кешированно "закраска" будет происходить ...

[Mavlyudov]

В общем, еще одну функцию написал.
Но не разобрался, почему не закрашивает в нужный цвет. Когда задавал цвет напрямую отдельными компонентами R,g,b, - работало.
Кто знает, отпишитесь пожалуйста. Ну и, возможно, другие недочеты есть.

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

function SetDownPixel(DC: HDC; X1, Y1: Integer; Color: COLORREF): COLORREF;
const
  cHeight = 1;
  cWidth = 1;
var
  bmpinfo: PBitmapInfo;
  colorRGB: PRGBQUAD;
  x,y,i: Integer;
  DataBuffer: array[0..cHeight-1,0..cWidth-1] of byte;
begin
  GetMem(bmpinfo, SizeOf(TBitmapInfo) + SizeOf(TRGBQUAD)*2);

  colorRGB:= @bmpinfo^.bmiColors[0];
  colorRGB^.rgbRed:= color;
  colorRGB^.rgbGreen:= color shr 8;
  colorRGB^.rgbBlue:= color shr 16;

  with bmpinfo.bmiHeader do begin
    biSize:= SizeOf(bmpinfo.bmiHeader);
    biWidth:= cWidth;
    biHeight:= cHeight;
    biPlanes:= 1;
    biBitCount:= 1;
    biCompression:= BI_RGB;
    biSizeImage:= 0;
    biXPelsPerMeter:= 0;
    biYPelsPerMeter:= 0;
    biClrUsed:= 0;
    biClrImportant:= 0;
  end;

  for x:= 0 to cwidth-1 do begin
    for y:= 0 to cheight-1 do begin
      DataBuffer[x,y]:= 0;
    end;
  end;

    StretchDIBits(DC,  x1, y1, cHeight, cWidth, 0, 0, cHeight, cWidth,
             @DataBuffer, bmpinfo^, DIB_RGB_COLORS, SRCCOPY);
  FreeMem(bmpinfo);
end;

[Alex2013]

В общем, еще одну функцию написал.
Но не разобрался, почему не закрашивает в нужный цвет. Когда задавал цвет напрямую отдельными компонентами R,g,b, - работало.
Кто знает, отпишитесь пожалуйста. Ну и, возможно, другие недочеты есть.

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

function SetDownPixel(DC: HDC; X1, Y1: Integer; Color: COLORREF): COLORREF;
const
  cHeight = 1;
  cWidth = 1;
var
  bmpinfo: PBitmapInfo;
  colorRGB: PRGBQUAD;
  x,y,i: Integer;
  DataBuffer: array[0..cHeight-1,0..cWidth-1] of byte;
begin
  GetMem(bmpinfo, SizeOf(TBitmapInfo) + SizeOf(TRGBQUAD)*2);

  colorRGB:= @bmpinfo^.bmiColors[0];
  colorRGB^.rgbRed:= color;
  colorRGB^.rgbGreen:= color shr 8;
  colorRGB^.rgbBlue:= color shr 16;

  with bmpinfo.bmiHeader do begin
    biSize:= SizeOf(bmpinfo.bmiHeader);
    biWidth:= cWidth;
    biHeight:= cHeight;
    biPlanes:= 1;
    biBitCount:= 1;
    biCompression:= BI_RGB;
    biSizeImage:= 0;
    biXPelsPerMeter:= 0;
    biYPelsPerMeter:= 0;
    biClrUsed:= 0;
    biClrImportant:= 0;
  end;

  for x:= 0 to cwidth-1 do begin
    for y:= 0 to cheight-1 do begin
      DataBuffer[x,y]:= 0;
    end;
  end;

    StretchDIBits(DC,  x1, y1, cHeight, cWidth, 0, 0, cHeight, cWidth,
             @DataBuffer, bmpinfo^, DIB_RGB_COLORS, SRCCOPY);
  FreeMem(bmpinfo);
end;

Может потому что RGB в "дикой природе" не встречается ? На самом деле там BGR ! (То есть стандартная раскладка в памяти Синий Зелений Красный) .
И вообще зачем такие сложности ? Это что попытка сделать независимый от режима экрана метод закраски ? Или что-то для печати на принтер ?
Так с этим обычный StretchDraw из конваса справляется .
Вот функция для тестирования и изменения битности битмапа .

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

   Function BitmapTest(var TB:TBitmap; Mode:TPixelFormat;
      F_Free:Boolean=true):Boolean ;
      Var
      CB:TBitmap;
      Begin
       Result:= tb.PixelFormat=mode ;
      if not Result then
      begin
      CB:=TBitmap.Create;
      cb.SetSize(tb.Width,tb.Height);
      cb.PixelFormat:=Mode;
      Cb.Canvas.Draw(0,0,TB);
      if F_Free then tb.free;
      Tb:=CB;
      end
      end;


[Mavlyudov]

Alex2013

Может потому что RGB в "дикой природе" не встречается ?

Так я ж вроде перевел из COLORREF в TColor.

Как было написано где-то в начале темы, не должно зависеть от Canvas

[Alex2013]

Alex2013

Может потому что RGB в "дикой природе" не встречается ?

Так я ж вроде перевел из COLORREF в TColor.

Как было написано где-то в начале темы, не должно зависеть от Canvas

Просто попробуй так:

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

  colorRGB^.rgbRed    := color shr 16;
  colorRGB^.rgbGreen  := color shr 8;
  colorRGB^.rgbBlue   := color;


Вникать сейчас лень, но это первое, что приходит в голову .

[Mavlyudov]

Думал, что не работает - вводил цвет числами от 0 до 15. Оказывается, так нельзя.
Ну или можно, но как правильно я не знаю.
Работает в моем варианте без обмена местами R и B
Сравнил с функцией SetPixel. Рисует оба красным

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

setpixel(Canvas.Handle,200,200,clred) ;
SetDownPixel(Canvas.Handle,100,100,clred);

Кстати, как правильно заполнять структуры из этих вариантов?

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

with bmpinfo.bmiHeader do begin ... end;

with bmpinfo^.bmiHeader do begin ... end;

Добавлено
Сделал заливку, какая-то она не быстрая оказалась эта функция, даже медленнее, чем SetPixel. Так и должно быть?
Вод код на winApi.

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

program Test1;

uses
  Windows,
  SysUtils;

const
   AppName = 'Test Pixel';
   WM_PAINT = $000F;
   WM_DESTROY = $0002;

function SetDownPixel(DC: HDC; X1, Y1: Integer; Color: COLORREF): COLORREF;
const
  cHeight = 1;
  cWidth = 1;
var
  bmpinfo: PBitmapInfo;
  colorRGB: PRGBQUAD;
  x,y,i: Integer;
  DataBuffer: array[0..cHeight-1,0..cWidth-1] of byte;
begin
  GetMem(bmpinfo, SizeOf(TBitmapInfo) + SizeOf(TRGBQUAD)*2);

  colorRGB:= @bmpinfo^.bmiColors[0];
  colorRGB^.rgbRed:= color;
  colorRGB^.rgbGreen:= color shr 8;
  colorRGB^.rgbBlue:= color shr 16;

  with bmpinfo.bmiHeader do begin
    biSize:= SizeOf(bmpinfo.bmiHeader);
    biWidth:= cWidth;
    biHeight:= cHeight;
    biPlanes:= 1;
    biBitCount:= 1;
    biCompression:= BI_RGB;
    biSizeImage:= 0;
    biXPelsPerMeter:= 0;
    biYPelsPerMeter:= 0;
    biClrUsed:= 0;
    biClrImportant:= 0;
  end;

  for x:= 0 to cwidth-1 do begin
    for y:= 0 to cheight-1 do begin
      DataBuffer[x,y]:= 0;
    end;
  end;

    StretchDIBits(DC,  x1, y1, cHeight, cWidth, 0, 0, cHeight, cWidth,
             @DataBuffer, bmpinfo^, DIB_RGB_COLORS, SRCCOPY);
  FreeMem(bmpinfo);
end;

function WindowProc(Window: HWnd; AMessage: UINT; WParam : WPARAM;
               LParam: LPARAM): LRESULT; stdcall; export;

var
   dc : hdc;
   ps : Tpaintstruct;
   iy, ix: integer;
   r : Trect;
   h, w: integer;
   tm_pnt: record
      beg_,
      end_: integer;
   end;

begin
   WindowProc := 0;

   case AMessage of
      wm_paint:
      begin
         dc := BeginPaint(Window, ps);
         GetClientRect(Window, r);
         tm_pnt.beg_ := GetTickCount();

         w := r.right - r.left;
         h := r.bottom - r.top;

         for ix := 0 to w - 1 do begin
            for iy := 0 to h - 1 do begin
         SetDownPixel(dc,ix, iy,$0000FF);
            end;
         end;

         tm_pnt.end_ := GetTickCount();

         with tm_pnt do begin
            DrawTextA(dc, pChar(IntToStr(tm_pnt.end_ - tm_pnt.beg_)), -1, r,
                     DT_SINGLELINE or DT_CENTER or DT_VCENTER);
         end;
         EndPaint(Window,ps);
         Exit;
      end;
      wm_Destroy:
      begin
         PostQuitMessage(0);
         Exit;
      end;
   end;
   WindowProc := DefWindowProc(Window, AMessage, WParam, LParam);
end;

{ Register the Window Class }
function WinRegister: Boolean;
var
   WindowClass: WndClass;
begin
   WindowClass.Style := cs_hRedraw or cs_vRedraw;
   WindowClass.lpfnWndProc := @WindowProc;
   WindowClass.cbClsExtra := 0;
   WindowClass.cbWndExtra := 0;
   WindowClass.hInstance := system.MainInstance;
   WindowClass.hIcon := LoadIcon(0, idi_Application);
   WindowClass.hCursor := LoadCursor(0, idc_Arrow);
   WindowClass.hbrBackground := GetStockObject(WHITE_BRUSH);
   WindowClass.lpszMenuName := nil;
   WindowClass.lpszClassName := AppName;

   Result := windows.RegisterClass(WindowClass) <> 0;
end;

{ Create the Window Class }
function WinCreate: HWnd;
var
   hWindow: HWnd;
begin
   hWindow := CreateWindow(AppName, 'Fast draw demo',
                     ws_OverlappedWindow, cw_UseDefault, cw_UseDefault,
                     cw_UseDefault, cw_UseDefault, 0, 0, system.MainInstance, nil);

   if hWindow <> 0 then begin
      ShowWindow(hWindow, CmdShow);
      ShowWindow(hWindow, SW_SHOW);
      UpdateWindow(hWindow);
   end;

   Result := hWindow;
end;


var
   AMessage: Msg;
   hWindow: HWnd;

begin
   if not WinRegister then begin
      MessageBox(0, 'Register failed', nil, mb_Ok);
      Exit;
   end;
   hWindow := WinCreate;
   if longint(hWindow) = 0 then begin
      MessageBox(0, 'WinCreate failed', nil, mb_Ok);
      Exit;
   end;

   while GetMessage(AMessage, 0, 0, 0) do begin
      TranslateMessage(AMessage);
      DispatchMessage(AMessage);
   end;
   Halt(AMessage.wParam);
end.


Добавлено
Думаю, что медленно из-за того, что выделяется и освобождается память через GetMem, FreeMem.
Да еще и в цикле крутится DataBuffer[x,y]:= 0;

Наверное, надо вынести всё ненужное за процедуру. Вроде можно как-то обойти выделение памяти для bmpinfo.
И как быть с DataBuffer ?

[Pavia]

Да еще и в цикле крутится DataBuffer[x,y]:= 0;

Вы вместо установки одного пикселя закрашиваете все пиксели на изображении вот оно и тормозит. Удалите два лишних цикла.

Вроде можно как-то обойти выделение памяти для bmpinfo.
И как быть с DataBuffer ?

Точно так же, храните свои данные в классе и передавайте объект в функцию.

Думал, что не работает - вводил цвет числами от 0 до 15. Оказывается, так нельзя.

В RGB24 Цвет кодируется интенсивностью, а не палитрой.

Кстати, как правильно заполнять структуры из этих вариантов?

Во FreePascal нужно явно разыменовывать указатели. Т.е. код со шляпой(^) верный.

[Mavlyudov]

Удалите два лишних цикла.

Где два лишних цикла? Окно закрашивается пикселами специально, чтобы оценить скорость отрисовки

Точно так же, храните свои данные в классе и передавайте объект в функцию.

Могли бы показать на примере?

[Alex2013]

Это лишение!

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

for x:= 0 to cwidth-1 do begin
    for y:= 0 to cheight-1 do begin
      DataBuffer[x,y]:= 0;
    end;
  end;


И это тоже...

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

for ix := 0 to w - 1 do begin
            for iy := 0 to h - 1 do begin
         SetDownPixel(dc,ix, iy,$0000FF);
            end;
         end;

Вот рабочий вариант Вашего кода

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

program Test1;

uses
  Windows,
  SysUtils;

const
   AppName = 'Test Pixel';
   WM_PAINT = $000F;
   WM_DESTROY = $0002;

function SetDownPixel(DC: HDC; X1, Y1,W,H: Integer; Color: COLORREF): COLORREF;
const
  cHeight = 1;
  cWidth = 1;
var
  bmpinfo: PBitmapInfo;
  colorRGB: PRGBQUAD;
  x,y,i: Integer;
  DataBuffer: array[0..cHeight-1,0..cWidth-1] of byte;
begin
  GetMem(bmpinfo, SizeOf(TBitmapInfo) + SizeOf(TRGBQUAD)*2);

  colorRGB:= @bmpinfo^.bmiColors[0];
  colorRGB^.rgbRed:= color;
  colorRGB^.rgbGreen:= color shr 8;
  colorRGB^.rgbBlue:= color shr 16;

  with bmpinfo^.bmiHeader  do begin
    biSize:= SizeOf(bmpinfo^.bmiHeader);
    biWidth:= cWidth;
    biHeight:= cHeight;
    biPlanes:= 1;
    biBitCount:= 1;
    biCompression:= BI_RGB;
    biSizeImage:= 0;
    biXPelsPerMeter:= 0;
    biYPelsPerMeter:= 0;
    biClrUsed:= 0;
    biClrImportant:= 0;
  end;

  DataBuffer[0,0]:= DIB_RGB_COLORS;

    StretchDIBits(DC,  x1, y1, W, h, 0, 0, cHeight, cWidth,
             @DataBuffer, bmpinfo^, DIB_RGB_COLORS, SRCCOPY);
  FreeMem(bmpinfo);
end;

function WindowProc(Window: HWnd; AMessage: UINT; WParam : WPARAM;
               LParam: LPARAM): LRESULT; stdcall; export;

var
   dc : hdc;
   ps : Tpaintstruct;
   iy, ix: integer;
   r : Trect;
   h, w: integer;
   tm_pnt: record
      beg_,
      end_: integer;
   end;

begin
   WindowProc := 0;

   case AMessage of
      wm_paint:
      begin
         dc := BeginPaint(Window, ps);
         GetClientRect(Window, r);
         tm_pnt.beg_ := GetTickCount();

         w := r.right - r.left;
         h := r.bottom - r.top;

       SetDownPixel(dc,r.left,r.top,W,H,$0000FF);//!!!! "Одним махом семерых побивахом!"

      // FillRect(dc,R,$FF00); // банальный FillRect почему-то не сработал разбираться лень  .

         tm_pnt.end_ := GetTickCount();

         with tm_pnt do begin
            DrawTextA(dc, pChar(IntToStr(tm_pnt.end_ - tm_pnt.beg_)), -1, r,
                     DT_SINGLELINE or DT_CENTER or DT_VCENTER);
         end;

         EndPaint(Window,ps);
         Exit;
      end;
      wm_Destroy:
      begin
         PostQuitMessage(0);
         Exit;
      end;
   end;
   WindowProc := DefWindowProc(Window, AMessage, WParam, LParam);
end;

{ Register the Window Class }
function WinRegister: Boolean;
var
   WindowClass: WndClass;
begin
   WindowClass.Style := cs_hRedraw or cs_vRedraw;
   WindowClass.lpfnWndProc := @WindowProc;
   WindowClass.cbClsExtra := 0;
   WindowClass.cbWndExtra := 0;
   WindowClass.hInstance := system.MainInstance;
   WindowClass.hIcon := LoadIcon(0, idi_Application);
   WindowClass.hCursor := LoadCursor(0, idc_Arrow);
   WindowClass.hbrBackground := GetStockObject(WHITE_BRUSH);
   WindowClass.lpszMenuName := nil;
   WindowClass.lpszClassName := AppName;

   Result := windows.RegisterClass(WindowClass) <> 0;
end;

{ Create the Window Class }
function WinCreate: HWnd;
var
   hWindow: HWnd;
begin
   hWindow := CreateWindow(AppName, 'Fast draw demo',
                     ws_OverlappedWindow, cw_UseDefault, cw_UseDefault,
                     cw_UseDefault, cw_UseDefault, 0, 0, system.MainInstance, nil);

   if hWindow <> 0 then begin
      ShowWindow(hWindow, CmdShow);
      ShowWindow(hWindow, SW_SHOW);
      UpdateWindow(hWindow);
   end;

   Result := hWindow;
end;


var
   AMessage: Msg;
   hWindow: HWnd;

begin
   if not WinRegister then begin
      MessageBox(0, 'Register failed', nil, mb_Ok);
      Exit;
   end;
   hWindow := WinCreate;
   if longint(hWindow) = 0 then begin
      MessageBox(0, 'WinCreate failed', nil, mb_Ok);
      Exit;
   end;

   while GetMessage(AMessage, 0, 0, 0) do begin
      TranslateMessage(AMessage);
      DispatchMessage(AMessage);
   end;
   Halt(AMessage.wParam);
end.


Уф ! Еще раз объясняю.... "По пикселям" такую работу как заполнение прямоугольной области делать крайне неэффективно.
И даже "для измерения скорости" подробное издевательство не приемлемо. А если идет обработка и фильтрация живого видео то кадр рассматривают исключительно как МАССИВ ДАННЫХ. А разные функции вывода на экран используют ОДИН РАЗ по завершению обработки для всего кадра разом.

Как думаешь сколько бы ЧАСОВ заняло рисование вот такого "зеркального лабиринта" если бы я строил его выводя каждый пиксель ОТДЕЛЬНО ? Парру тройку лет или больше ?

А на самом деле в моей программе эту "красоту" в реальном времени рисует. (обрати внимание на ч/б окошечко в правом нижнем углу скрина это захват видео с камеры - так вот "скорость построения цепочки итераций" в моей программе почти такая же как при прямой съемке видео с экрана на котором выводится изображение с камеры )

[Mavlyudov]

Alex2013
Не в том задача, чтобы исправить функцию так, чтобы она закрашивала.
А в том, чтобы сделать функцию отрисовки ОДНОГО пиксела быстрее, чем SetPixel, и без Canvas, чтобы только WinAPi.
Для того, чтобы потом сделать через эту функцию отрисовку прямой и закраску. Это нужно для графического cad-приложения.

Так, что Вы, к сожалению, не помогли

[Alex2013]

Alex2013
Не в том задача, чтобы исправить функцию так, чтобы она закрашивала.
А в том, чтобы сделать функцию отрисовки ОДНОГО пиксела быстрее, чем SetPixel, и без Canvas, чтобы только WinAPi.
Для того, чтобы потом сделать через эту функцию отрисовку прямой и закраску. Это нужно для графического cad-приложения.

Так, что Вы, к сожалению, не помогли

Очень жаль, что вы меня как бы "не слышите"...
А говорю я примерно одно и то же "Функции Вывода из Вин АПИ не годятся для работы с одним пикселем".
(То есть такая возможность есть... но значительно быстрее выводить на экран целый МАССИВ данных (растр) потому, что только в это случае работают разные оптимизации и аппаратное ускорение )
Кстати, вашем примере ответ уже найден, но вы его так и не увидели ...
Пробуйте так !

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

function SetDownPixel(DC: HDC; X1, Y1,W,H: Integer; Color: COLORREF): COLORREF;
type TRGBArray = Array[0..1000] of RGBQUAD;
PRGBArray = ^TRGBArray;

var lpbmi : PBITMAPINFO;
lpTargetBits : Pointer;
DDC : HDC;
Bitmap : HBITMAP;
BB : PRGBArray;
i:Integer;
dwTargetHeaderSize : DWORD;
RGB:RGBQuad;
begin

dwTargetHeaderSize := sizeof ( BITMAPINFO ) + ( 32*32 * sizeof( RGBQUAD ) );
GetMem (lpbmi, dwTargetHeaderSize);
lpbmi^.bmiHeader.biSize := sizeof (BITMAPINFOHEADER);
lpbmi^.bmiHeader.biWidth := 32;
lpbmi^.bmiHeader.biHeight := 32;
lpbmi^.bmiHeader.biPlanes := 1;
lpbmi^.bmiHeader.biBitCount := 32;
lpbmi^.bmiHeader.biCompression := BI_RGB;
lpbmi^.bmiHeader.biSizeImage := 0;
lpbmi^.bmiHeader.biXPelsPerMeter := 0;
lpbmi^.bmiHeader.biYPelsPerMeter := 0;
lpbmi^.bmiHeader.biClrUsed := 0;
lpbmi^.bmiHeader.biClrImportant := 0;

DDC := GetDC (0);
Bitmap := CreateDIBSection (DDC, lpbmi^, DIB_RGB_COLORS, lpTargetBits, 0, 0 );
BB:=lpTargetBits;
// Вся работа с "точками" происходит  там где это еще просто данные .
For i:=0 to (32*32)-1 do begin
Rgb.rgbBlue:=random(255);
Rgb.rgbGreen:=random(255);
Rgb.rgbRed:=random(255);
BB^[i]:= rgb;
end;
// Нарисовали ?  Вывели ! ОДИН РАЗ !
StretchDIBits(DC,  x1, y1, W, h, 0, 0,32,32, lpTargetBits, lpbmi^,DIB_RGB_COLORS,SRCCOPY);
FreeMem (lpbmi);
end;


Суть примера в том, что в нем я работаю С ДАННЫМИ а не с точками. Разумеется "цветные кирпичики" из того примера легко превращаются в пиксели, но я как раз хотел показать, что физический пиксель не так уж важен.
Ps
На всякий случай "пиксельный вариант"(кстати работает тоже на удивление быстро хотя я использую 32 битный пиксель ).

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

function SetDownPixel2(DC: HDC; X1, Y1,W,H: Integer; Color: COLORREF): COLORREF;
type TRGBArray = Array[0..1] of RGBQUAD;
PRGBArray = ^TRGBArray;

var lpbmi : PBITMAPINFO;
lpTargetBits : Pointer;
DDC : HDC;
Bitmap : HBITMAP;
BB : PRGBArray;
X,Y:Integer;
dwTargetHeaderSize : DWORD;
RGB:RGBQuad;
begin

dwTargetHeaderSize := sizeof ( BITMAPINFO ) + ( W*H * sizeof( RGBQUAD ) );
GetMem (lpbmi, dwTargetHeaderSize);
lpbmi^.bmiHeader.biSize := sizeof (BITMAPINFOHEADER);
lpbmi^.bmiHeader.biWidth := w;
lpbmi^.bmiHeader.biHeight := h;
lpbmi^.bmiHeader.biPlanes := 1;
lpbmi^.bmiHeader.biBitCount := 32;
lpbmi^.bmiHeader.biCompression := BI_RGB;
lpbmi^.bmiHeader.biSizeImage := 0;
lpbmi^.bmiHeader.biXPelsPerMeter := 0;
lpbmi^.bmiHeader.biYPelsPerMeter := 0;
lpbmi^.bmiHeader.biClrUsed := 0;
lpbmi^.bmiHeader.biClrImportant := 0;

DDC := GetDC (0);
Bitmap := CreateDIBSection (DDC, lpbmi^, DIB_RGB_COLORS, lpTargetBits, 0, 0 );
BB:=lpTargetBits;
//Вся прорисовка должна происходить тут !
// До того как данные станут точками....

For y:=0 to h-1  do
For x:=0 to w-1 do begin
Rgb.rgbBlue:=random(255);
Rgb.rgbGreen:=random(255);
Rgb.rgbRed:=random(255);
BB^[X+(Y*W)]:= rgb;
end;
//-------------------------------------------
// Средствами WinAPI вывожу полностью сформированный кадр !

StretchDIBits(DC,  x1, y1, W, h, 0, 0,w,h, lpTargetBits, lpbmi^,DIB_RGB_COLORS,SRCCOPY);
freemem(lpbmi);
end;


Зы Зы
Разумеется в основной программе эти процедуры вызываются только один раз (без цикла или та или другая ).

Надеюсь, что хоть на это раз Вы все-же поймете меня верно . :
Зы Зы Зы
В примере вполне возможно есть утечки памяти. (нет ни одного ReleaseDC и т.п. ) Но для демки это неважно.

94 миллисекунды с окном по умолчанию(примерно 1500х800) 172 миллисекунды в полно экранном режиме 1920х1080 .
Но главная фишка в том что вывод "просчитанного" кадра в окно происходит почти мгновенно . То есть если закомментировать цикл заполнения буфера цветным шумом то счетчик покажет НОЛЬ

Извиняюсь за упорную но видимо неуклюжую попытку разъяснить то что мне очевидно ... Но вы действительно "зацепились" за довольно фундаментальную особенность WinAPI без понимания которой ни о каком быстром выводе на экран речи быть не может.
Кстати спасибо за StretchDIBits я об этой функции даже не слышал. ( По идее это еще более прямой путь чем использование TBitmap.RawImage )
Для сравнения запустил исходный пример и в первый раз ДОЖДАЛСЯ завершения закраски, получил умопомрачительные 52973 миллисекунды... Не хилое такое ускорение у меня получилось ... аккурат на три прядка !

Добавлено спустя 20 часов 20 минут 41 секунду:
Выкинул немного лишнего кода...

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

function SetDownPixel2(DC: HDC; X1, Y1,W,H: Integer; Color: COLORREF): COLORREF;
type TRGBArray = Array[0..1] of RGBQUAD;
PRGBArray = ^TRGBArray;

var lpbmi : PBITMAPINFO;
lpTargetBits : Pointer;
Bitmap : HBITMAP;
BB : PRGBArray;
X,Y:Integer;
dwTargetHeaderSize : DWORD;
RGB:RGBQuad;
begin

dwTargetHeaderSize := sizeof ( BITMAPINFO ) + ( W*H * sizeof( RGBQUAD ) );
GetMem (lpbmi, dwTargetHeaderSize);
lpbmi^.bmiHeader.biSize := sizeof (BITMAPINFOHEADER);
lpbmi^.bmiHeader.biWidth := w;
lpbmi^.bmiHeader.biHeight := h;
lpbmi^.bmiHeader.biPlanes := 1;
lpbmi^.bmiHeader.biBitCount := 32;
lpbmi^.bmiHeader.biCompression := BI_RGB;
lpbmi^.bmiHeader.biSizeImage := 0;
lpbmi^.bmiHeader.biXPelsPerMeter := 0;
lpbmi^.bmiHeader.biYPelsPerMeter := 0;
lpbmi^.bmiHeader.biClrUsed := 0;
lpbmi^.bmiHeader.biClrImportant := 0;


With lpbmi^ do BB:=@bmiColors;
For y:=0 to h-1  do
For x:=0 to w-1 do begin
Rgb.rgbBlue:=random(255);
Rgb.rgbGreen:=random(255);
Rgb.rgbRed:=random(255);
BB^[X+(Y*W)]:= rgb;
end;
StretchDIBits(DC,  x1, y1, W, h, 0, 0,w,h,BB, lpbmi^,DIB_RGB_COLORS,SRCCOPY);
freemem(lpbmi);
end;


Заработало еще быстрее... 31 миллисекунда с окном по умолчанию(примерно 1500х800) 93 миллисекунды в полноэкранном режиме 1920х1080 .

[Alex2013]

Вот за такой скрин уже нестыдно ...
(По просьбе трудящихся :закраска треугольника, линии,точки "в чистом WinAPI" )

За код правда особой гордости не испытываю... Однако динамика при изменения размера окна радует .

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

program MagicDraw;

uses
  Windows,
  SysUtils;

const
   AppName = 'magic_draw';
   WM_PAINT = $000F;
   WM_DESTROY = $0002;

   //принадлежность точки треугольнику
   function Prin(x,y,x1,y1,x2,y2,x3,y3:integer):boolean;
   var s,s1,s2,s3:real;
   begin
   //определим удвоенные площади 4х треугольников
   s:=abs((x1-x3)*(y2-y3)-(x2-x3)*(y1-y3));//основного
   s1:=abs((x-x3)*(y2-y3)-(x2-x3)*(y-y3)); //и 3х внутренних
   s2:=abs((x1-x3)*(y-y3)-(x-x3)*(y1-y3));
   s3:=abs((x1-x)*(y2-y)-(x2-x)*(y1-y));
   Prin:=abs(s-s1-s2-s3)<0.1;//если площади равны с заданной точностью, точка в треугольнике
   end;

function WindowProc(Window: HWnd; AMessage: UINT; WParam : WPARAM;
               LParam: LPARAM): LRESULT; stdcall; export;

var
   dc : hdc;
   ps : Tpaintstruct;
   iy, ix: integer;
   r : Trect;
   h, w: integer;
   tm_pnt: record
      beg_,
      end_: integer;
   end;



   type TRGBArray = Array[0..0] of RGBQUAD;
PRGBArray = ^TRGBArray;

var lpbmi : PBITMAPINFO;
lpTargetBits : Pointer;
Bitmap : HBITMAP;
BB : PRGBArray;
X,Y:Integer;
dwTargetHeaderSize : DWORD;
RGB:RGBQuad;

Procedure Init_Magic;
Begin
dwTargetHeaderSize := sizeof ( BITMAPINFO ) + ( W*H * sizeof( RGBQUAD ) );
GetMem (lpbmi, dwTargetHeaderSize);
lpbmi^.bmiHeader.biSize := sizeof (BITMAPINFOHEADER);
lpbmi^.bmiHeader.biWidth := w;
lpbmi^.bmiHeader.biHeight := h;
lpbmi^.bmiHeader.biPlanes := 1;
lpbmi^.bmiHeader.biBitCount := 32;
lpbmi^.bmiHeader.biCompression := BI_RGB;
lpbmi^.bmiHeader.biSizeImage := 0;
lpbmi^.bmiHeader.biXPelsPerMeter := 0;
lpbmi^.bmiHeader.biYPelsPerMeter := 0;
lpbmi^.bmiHeader.biClrUsed := 0;
lpbmi^.bmiHeader.biClrImportant := 0;

BB:=@lpbmi^.bmiColors;
end;

Procedure Magic_SetPixel (X2,Y2:Integer;RGB2:RGBQuad );
Begin
  BB^[X2+(Y2*W)]:= rgb2;
end;

Procedure End_Of_Magic;
begin
StretchDIBits(DC, r.left, r.top, w, h, 0, 0,w,h,BB, lpbmi^,DIB_RGB_COLORS,SRCCOPY);
freemem(lpbmi);
end;

procedure DrawLine(x1,y1, x2,y2: Integer;RGB2:RGBQuad );
var b,dx,dy,y,x,i:integer;
begin
   dx:=abs(x2-x1);
   dy:=abs(y2-y1);

   if dx >= dy then
   begin
     if (x1<x2) then
       for i := x1 to x2 do
       begin
         y:=Round(((y2-y1)/(x2-x1))*i + (y1-x1*((y2-y1)/(x2-x1))));
         Magic_SetPixel (i,y,RGB2);
       end;

     if (x2<x1) then
       for i := x2 to x1 do
       begin
         y:=Round(((y2-y1)/(x2-x1))*i + (y1-x1*((y2-y1)/(x2-x1))));
         Magic_SetPixel(i,y,RGB2);
       end;
   end;

   if dx<dy then
   begin
     if (y1<y2) then
       for i := y1 to y2 do
       begin
         x:=Round(((x2-x1)/(y2-y1))*i + (x1-y1*((x2-x1)/(y2-y1))));
         Magic_SetPixel(x,i,RGB2);
       end;

     if (y2<y1) then
       for i := y2 to y1 do
       begin
         x:=Round(((x2-x1)/(y2-y1))*i + (x1-y1*((x2-x1)/(y2-y1))));
         Magic_SetPixel(x,i,RGB2);
       end;
   end;

  // Form1.Image1.Picture.Bitmap.Assign(bmp);
end;
var Xmin,Xmax,Xt1,Xt2,Xt3:integer;
    Yt1,Yt2,Yt3,XX1,XX2:integer;

begin
   WindowProc := 0;

   case AMessage of
      wm_paint:
      begin
         dc := BeginPaint(Window, ps);
         GetClientRect(Window, r);
         w := r.right - r.left;
         h := r.bottom - r.top;

    RGB.rgbRed:= 255;
    RGB.rgbGreen:=0;
    RGB.rgbBlue:=0;

    Init_Magic;       //Подготовка к страшному колдунству ! :))
    //"Горит пентаграмма у древнего храма..."

       tm_pnt.beg_ := GetTickCount();

       for iy := 0 to h-1 do
        begin
          RGB.rgbRed:=(255*iy)div h-1;
          FillDWord(BB^[iy*W],w,Dword(RGB));
        end;
    RGB.rgbRed:= 255;
    RGB.rgbGreen:=255;
    RGB.rgbBlue:=0;
    Xt1:=w div 4;Yt1:=h div 5;
    Xt2:=w div 2;Yt2:=h-h div 5;
    Xt3:=(w div 4)*3;Yt3:=h-h div 3;

{Закраска треугольника:  Тупой вариант
    for iy := min(Yt1,min(Yt2,Yt3)) to max(Yt1,max(Yt2,Yt3))  do begin
      for ix:=min(Xt1,min(Xt2,Xt3))  to max(Xt1,max(Xt2,Xt3)) do begin
        //принадлежность точки треугольнику
        If  Prin(ix,iy,Xt1,Yt1,Xt2,Yt2,Xt3,Yt3) then
          Magic_SetPixel( ix, iy, RGB);
            end;
         end;
}

// Закраска треугольника: Чуть умнее...
Xmin:=min(Xt1,min(Xt2,Xt3));Xmax:= max(Xt1,max(Xt2,Xt3));
for iy := min(Yt1,min(Yt2,Yt3)) to max(Yt1,max(Yt2,Yt3))  do begin
   for ix:=Xmin  to Xmax do
     //принадлежность точки треугольнику
     If  Prin(ix,iy,Xt1,Yt1,Xt2,Yt2,Xt3,Yt3) then  Begin
     XX1:=iX; Break;
     end;
   for ix:=XX1  To Xmax do
     //принадлежность точки треугольнику
     If  not Prin(ix,iy,Xt1,Yt1,Xt2,Yt2,Xt3,Yt3) then  Begin
     XX2:=iX-1; Break;
     end;
     RGB.rgbBlue:=(255*iy)div h;
     FillDWord(BB^[W*IY+XX1],XX2-XX1,Dword(RGB));
    end;

    tm_pnt.end_ := GetTickCount();

    RGB.rgbRed:= 0;
    RGB.rgbGreen:=255;
    RGB.rgbBlue:=0;
   DrawLine(0,0,w-1,h-1,rgb);
   DrawLine(w-1,0,0,h-1,rgb);

       End_Of_Magic; // Что-бы демоны не разбегались... :))

        with tm_pnt do begin
            DrawTextA(dc, pChar(IntToStr(tm_pnt.end_ - tm_pnt.beg_)), -1, r,
                     DT_SINGLELINE or DT_CENTER or DT_VCENTER);
         end;

         EndPaint(Window,ps);
         Exit;
      end;
      wm_Destroy:
      begin
         PostQuitMessage(0);
         Exit;
      end;
   end;

   WindowProc := DefWindowProc(Window, AMessage, WParam, LParam);
end;

{ Register the Window Class }
function WinRegister: Boolean;
var
   WindowClass: WndClass;
begin
   WindowClass.Style := cs_hRedraw or cs_vRedraw;
   WindowClass.lpfnWndProc := @WindowProc;
   WindowClass.cbClsExtra := 0;
   WindowClass.cbWndExtra := 0;
   WindowClass.hInstance := system.MainInstance;
   WindowClass.hIcon := LoadIcon(0, idi_Application);
   WindowClass.hCursor := LoadCursor(0, idc_Arrow);
   WindowClass.hbrBackground := GetStockObject(WHITE_BRUSH);
   WindowClass.lpszMenuName := nil;
   WindowClass.lpszClassName := AppName;

   Result := windows.RegisterClass(WindowClass) <> 0;
end;

{ Create the Window Class }
function WinCreate: HWnd;
var
   hWindow: HWnd;
begin
   hWindow := CreateWindow(AppName, 'Fast draw demo',
                     ws_OverlappedWindow, cw_UseDefault, cw_UseDefault,
                     cw_UseDefault, cw_UseDefault, 0, 0, system.MainInstance, nil);

   if hWindow <> 0 then begin
      ShowWindow(hWindow, CmdShow);
      ShowWindow(hWindow, SW_SHOW);
      UpdateWindow(hWindow);
   end;

   Result := hWindow;
end;


var
   AMessage: Msg;
   hWindow: HWnd;

begin
   if not WinRegister then begin
      MessageBox(0, 'Register failed', nil, mb_Ok);
      Exit;
   end;
   hWindow := WinCreate;
   if longint(hWindow) = 0 then begin
      MessageBox(0, 'WinCreate failed', nil, mb_Ok);
      Exit;
   end;

   while GetMessage(AMessage, 0, 0, 0) do begin
      TranslateMessage(AMessage);
      DispatchMessage(AMessage);
   end;

   Halt(AMessage.wParam);
end.