pixel单元测试成功

最近开发了一个pixel单元，只提供setpixel和getpixel以及绑定回调函数

鼠标键盘暂时不能响应

fps一般在1000上下，做了一些特殊的优化

相关文件：

底层 gla.pas 由陈琛负责开发，winapi接口等

{
GL Addons
对GL、GLU中的东西进行了一定的整合
（或许）可以简化使用
FPC5719
2019.3
}
unit gla;

interface

uses
	windows,gMap,gUtil;

const
	GLACLASSNAME='GLAWNDCLS';

type
	TGLACallback=procedure(wp,lp:DWord);
	TGLALess=specialize TLess<DWord>;
	TGLACallbackMap=specialize TMap<DWord,TGLACallback,TGLALess>;
	TGLACallbackMapIterator=TGLACallbackMap.TIterator;

function glaInit:boolean;
function glaCreateWindow(x,y,w,h:DWord;s:PChar):DWord;
procedure glaBindFunc(msg:DWord;func:TGLACallback);
procedure glaLoop;
procedure glaRedisplay;

{ procedure glaPutPixel(x,y,c:DWord); }
{ function glaGetPixel(x,y:DWord):DWord; }

var
	glaDC:DWord;

implementation

var
	__map:TGLACallbackMap;
	__dc,__hw:DWord;

function __WindowProc(wnd,msg,wp,lp:DWord):DWord;stdcall;export;
var
	i:TGLACallbackMapIterator;
begin
	i:=__map.Find(msg);
	if i=NIL then
		exit(DefWindowProc(wnd,msg,wp,lp))
	else begin
		i.Value(wp,lp);
		exit(0);
	end;
end;

function glaInit:boolean;
var
	cls:WNDCLASS;
begin
	__map:=TGLACallbackMap.Create;
	with cls do begin
		Style:=CS_HREDRAW or CS_VREDRAW;
		lpfnWndProc:=WndProc(@__WindowProc);
		cbClsExtra:=0;
		cbWndExtra:=0;
		hInstance:=system.MainInstance;
		hIcon:=LoadIcon(0,IDI_APPLICATION);
		hCursor:=LoadCursor(0,IDC_ARROW);
		hbrBackground:=0;
		lpszMenuName:=NIL;
		lpszClassName:=GLACLASSNAME;
	end;
	exit(RegisterClass(cls)<>0);
end;
function glaCreateWindow(x,y,w,h:DWord;s:PChar):DWord;
var
	hw:DWord;
begin
	hw:=CreateWindow(GLACLASSNAME,s,WS_OVERLAPPEDWINDOW,x,y,
		w,h,0,0,system.MainInstance,NIL);
	__hw:=hw;
	if hw<>0 then begin
		__dc:=GetDC(hw);
		glaDC:=__dc;
		ShowWindow(hw,SW_SHOW);
		UpdateWindow(hw);
	end;
	exit(hw);
end;
procedure glaBindFunc(msg:DWord;func:TGLACallback);
begin
	__map.Items[msg]:=func;
end;
procedure glaLoop;
var
	amsg:MSG;
begin
	glaRedisplay;
	while GetMessage(@amsg,0,0,0) do begin
		TranslateMessage(amsg);
		DispatchMessage(amsg);
	end;
end;
procedure glaRedisplay;
begin
	InvalidateRect(__hw,NIL,TRUE);
	UpdateWindow(__hw);
end;

{ procedure glaPutPixel(x,y,c:DWord); }
{ begin }
	{ SetPixelv(__dc,x,y,c); }
{ end; }
{ function glaGetPixel(x,y:DWord):DWord; }
{ begin }
	{ exit(GetPixel(__dc,x,y)); }
{ end; }

end.

底层 pixel.pas 自己写的，做了一些优化以及整合

unit pixel;
{$mode objfpc}
interface
 uses windows,gla,fpwritebmp,fpimage;
 type
  color3=record
   r,g,b:byte;
  end;
  a_color3=array of color3;
  aa_color3=array of a_color3;
  on_display=procedure;
 var
  _window:aa_color3;
  changed:boolean;
  windowsize_x,windowsize_y:longint;
  tdc,tbmp:dword;
  user_display:on_display;
 procedure init;
 procedure createwindow(p_x,p_y,s_x,s_y:longint;title:Pchar);
 procedure setcolor(x,y:longint;rr,gg,bb:byte);
 function getcolor(x,y:longint):color3;
implementation
 procedure init;
 begin
  glaInit;
  tdc:=CreateCompatibleDC(0);
 end;
 procedure _write;
 var
  i,j:longint;
  writer:tfpcustomimagewriter;
  img:tfpmemoryimage;
  px:tfpcolor;
 begin
  writer:=tfpwriterbmp.create;
  img:=tfpmemoryimage.create(windowsize_x,windowsize_y);
  for i:=0 to img.width-1 do
   for j:=0 to img.height-1 do
    begin
     px:=img.colors[i,j];
     with px do
      begin
       red:=_window[i,j].r*255;
       green:=_window[i,j].g*255;
       blue:=_window[i,j].b*255;
      end;
     img.colors[i,j]:=px;
    end;
  { tfpwriterbmp(writer).usealpha:=false; }
  img.savetofile('cache.bmp',writer);
  img.destroy;
 end;
 procedure display(wp,lp:dword);
 begin
  if not changed then
   BitBlt(glaDC,0,0,640,480,tdc,0,0,SRCCOPY)
  else
   begin
    _write;
    tbmp:=LoadImage(0,'cache.bmp',IMAGE_BITMAP,windowsize_x,windowsize_y,LR_LOADFROMFILE);
	SelectObject(tdc,tbmp);
	BitBlt(glaDC,0,0,windowsize_x,windowsize_y,tdc,0,0,SRCCOPY);
    DeleteObject(tbmp);
   end;
  changed:=false;
  user_display;
 end;
 procedure destroy(wp,lp:dword);
 begin
  PostQuitMessage(0);
  DeleteDC(tdc);
 end;
 procedure resize(x,y:longint);
 var
  i:longint;
 begin
  setlength(_window,x);
  for i:=0 to x-1 do
   setlength(_window[i],y);
 end;
 procedure createwindow(p_x,p_y,s_x,s_y:longint;title:Pchar);
 begin
  windowsize_x:=s_x;
  windowsize_y:=s_y;
  resize(s_x,s_y);
  glaCreateWindow(p_x,p_y,s_x,s_y,title);
  glaBindFunc(WM_PAINT,@display);
  glaBindFunc(WM_DESTROY,@destroy);
  glaloop;
 end;
 procedure setcolor(x,y:longint;rr,gg,bb:byte);
 begin
  if (_window[x-1,y-1].r<>rr)or(_window[x-1,y-1].r<>rr)or(_window[x-1,y-1].r<>rr) then
   begin
    with _window[x-1,y-1] do
     begin
      r:=rr;
      g:=gg;
      b:=bb;
     end;
    changed:=true;
   end;
 end;
 function getcolor(x,y:longint):color3;
 begin
  exit(_window[x-1,y-1]);
 end;
begin
 changed:=false;
end.

测试以及使用说明的代码： testpixel1.pas

uses pixel,sysutils;
var
 fps:longint;
 time:extended;
 procedure __display;
 var
  i,j:longint;
 begin
  for i:=1 to 400 do
   for j:=1 to 400 do
    setcolor(i,j,i mod 255,j mod 255,(i+j)mod 255);
  fps:=fps+1;
  if (now-time)*86400>=1 then
   begin
    writeln(fps);
    fps:=0;
    time:=now;
    { writeln(changed); }
   end;
 end;
begin
 init;
 user_display:=@__display;
 time:=now;
 createwindow(10,10,400,400,'test');
end.

testpixel2.pas

uses pixel,sysutils;
var
 fps:longint;
 time:extended;
 procedure __display;
 var
  i,j:longint;
 begin
  for i:=1 to 400 do
   for j:=1 to 400 do
    if(i=5)or(j=5) then
     setcolor(i,j,255,255,255);
     { setcolor(i,j,255,255,255); }
  fps:=fps+1;
  if (now-time)*86400>=1 then
   begin
    writeln(fps);
    fps:=0;
    time:=now;
    { writeln(changed); }
   end;
 end;
begin
 init;
 user_display:=@__display;
 time:=now;
 createwindow(10,10,400,400,'test');
end.

Never too old to learn.

目录