pixel单元bug修改

之前的pixel单元出现了一些错误，包括但不限于：

释放句柄后没有创建直接绘图，导致在有指针申请动态内存的时候出现“内存重合”的现象，已修复
如果在最开始一次画图之前没有修改，那么会访问到空handle
处理display事件的时候没有传递参数

现在是修正后的代码：

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(wp,lp:dword);
 var
  _window:aa_color3;
  changed:boolean;
  windowsize_x,windowsize_y:longint;
  tdc,tbmp:dword;
  user_display:on_display;
  _first:boolean;
 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
    if not _first then
     DeleteObject(tbmp)
    else
     _first:=false;
    _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);
   end;
  changed:=false;
  user_display(wp,lp);
 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
 _first:=true;
 changed:=true;
end.

Never too old to learn.

目录