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

Вопросы программирования на Free Pascal, использования компилятора и утилит.

Модератор: Модераторы

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

Сообщение Mavlyudov » 16.05.2018 16:24:46

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.
Mavlyudov
новенький
 
Сообщения: 50
Зарегистрирован: 24.01.2010 20:35:23

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

Сообщение Alex2013 » 18.05.2018 02:54:24

Mavlyudov писал(а):[

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


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


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

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

Сообщение Mavlyudov » 09.10.2019 23:46:20

В общем, еще одну функцию написал.
Но не разобрался, почему не закрашивает в нужный цвет. Когда задавал цвет напрямую отдельными компонентами 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;
Mavlyudov
новенький
 
Сообщения: 50
Зарегистрирован: 24.01.2010 20:35:23

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

Сообщение Alex2013 » 11.10.2019 08:51:09

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;


Может потому что RGB в "дикой природе" не встречается ? На самом деле там BGR ! :idea: (То есть стандартная раскладка в памяти Синий Зелений Красный) .
И вообще зачем такие сложности ? Это что попытка сделать независимый от режима экрана метод закраски ? Или что-то для печати на принтер ?
Так с этим обычный 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;
Последний раз редактировалось Alex2013 11.10.2019 09:22:44, всего редактировалось 2 раз(а).
Alex2013
долгожитель
 
Сообщения: 2922
Зарегистрирован: 03.04.2013 11:59:44

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

Сообщение Mavlyudov » 11.10.2019 09:11:15

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

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

Как было написано где-то в начале темы, не должно зависеть от Canvas
Mavlyudov
новенький
 
Сообщения: 50
Зарегистрирован: 24.01.2010 20:35:23

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

Сообщение Alex2013 » 11.10.2019 09:14:58

Mavlyudov писал(а):Alex2013
Alex2013 писал(а):Может потому что RGB в "дикой природе" не встречается ?

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

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

Просто попробуй так:
Код: Выделить всё
  colorRGB^.rgbRed    := color shr 16;
  colorRGB^.rgbGreen  := color shr 8;
  colorRGB^.rgbBlue   := color;

Вникать сейчас лень, но это первое, что приходит в голову .
Alex2013
долгожитель
 
Сообщения: 2922
Зарегистрирован: 03.04.2013 11:59:44

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

Сообщение Mavlyudov » 11.10.2019 10:29:56

Думал, что не работает - вводил цвет числами от 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 ?
Mavlyudov
новенький
 
Сообщения: 50
Зарегистрирован: 24.01.2010 20:35:23

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

Сообщение Pavia » 11.10.2019 12:08:30

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

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

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

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

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

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

Во FreePascal нужно явно разыменовывать указатели. Т.е. код со шляпой(^) верный.
Аватара пользователя
Pavia
постоялец
 
Сообщения: 290
Зарегистрирован: 07.01.2011 12:46:51

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

Сообщение Mavlyudov » 11.10.2019 14:13:58

Pavia писал(а):Удалите два лишних цикла.

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

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

Могли бы показать на примере?
Mavlyudov
новенький
 
Сообщения: 50
Зарегистрирован: 24.01.2010 20:35:23

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

Сообщение Alex2013 » 12.10.2019 12:25:39

Это лишение!
Код: Выделить всё
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.


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

Как думаешь сколько бы ЧАСОВ заняло рисование вот такого "зеркального лабиринта" если бы я строил его выводя каждый пиксель ОТДЕЛЬНО ? Парру тройку лет или больше ?
ИзображениеИзображение
А на самом деле в моей программе эту "красоту" в реальном времени рисует. (обрати внимание на ч/б окошечко в правом нижнем углу скрина это захват видео с камеры - так вот "скорость построения цепочки итераций" в моей программе почти такая же как при прямой съемке видео с экрана на котором выводится изображение с камеры )
Alex2013
долгожитель
 
Сообщения: 2922
Зарегистрирован: 03.04.2013 11:59:44

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

Сообщение Mavlyudov » 12.10.2019 22:45:03

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

Так, что Вы, к сожалению, не помогли
Mavlyudov
новенький
 
Сообщения: 50
Зарегистрирован: 24.01.2010 20:35:23

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

Сообщение Alex2013 » 13.10.2019 02:25:05

Mavlyudov писал(а):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;

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

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

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

Добавлено спустя 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 19.09.2021 15:27:38, всего редактировалось 3 раз(а).
Alex2013
долгожитель
 
Сообщения: 2922
Зарегистрирован: 03.04.2013 11:59:44

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

Сообщение Alex2013 » 24.10.2019 05:48:09

Вот за такой скрин уже нестыдно ...
(По просьбе трудящихся :закраска треугольника, линии,точки "в чистом WinAPI" :idea: )
Изображение
За код правда особой гордости не испытываю... Однако динамика при изменения размера окна радует .
Код: Выделить всё
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.
Alex2013
долгожитель
 
Сообщения: 2922
Зарегистрирован: 03.04.2013 11:59:44

Пред.

Вернуться в Free Pascal Compiler

Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 5

Рейтинг@Mail.ru