{
GL Addons
对GL、GLU中的东西进行了一定的整合
（或许）可以简化使用
FPC5719 and ZCY
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_POPUP,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.

{$mode objfpc}
unit pixel2;
interface
 uses gla,fpwritebmp,fpimage,windows;
 type
  color3=record
   r,g,b:byte;
  end;
  a_color3=array of color3;
  aa_color3=array of a_color3;
  _procedure=procedure (wp,lp:dword);
  var
  { _window=class }
   map:aa_color3;
   paint,keydown,keyup,lbuttondown,rbuttondown,mbuttondown,lbuttonup,rbuttonup,mbuttonup:_procedure;
   window_changed,first_load:boolean;
   tdc,tbmp:dword;
   {constructor}procedure create;
   {destructor}procedure destroy;{override;}
   procedure _destroy(wp,lp:dword);
   procedure establish(sx,sy,ssx,ssy:longint;title:pchar);
   procedure resize(x,y:longint);
   procedure redraw;
   procedure display(wp,lp:dword);
   procedure setpixel(x,y:longint;col:color3);
   function getpixel(x,y:longint):color3;
  { end; }
 function make_color(r,g,b:longint):color3;
implementation
 procedure _procedure_null(wp,lp:dword);
 begin
  //What the fuck?
 end;
 {constructor}procedure {_window.}create;
 begin
  tdc:=CreateCompatibleDC(0);
  window_changed:=true;
  paint:=@_procedure_null;
  keydown:=@_procedure_null;
  keyup:=@_procedure_null;
  lbuttondown:=@_procedure_null;
  rbuttondown:=@_procedure_null;
  mbuttondown:=@_procedure_null;
  lbuttonup:=@_procedure_null;
  rbuttonup:=@_procedure_null;
  mbuttonup:=@_procedure_null;
  first_load:=true;
 end;
 {destructor}procedure destroy;{override;}
 begin
  _destroy(0,0);
 end;
 procedure _destroy(wp,lp:dword);
 begin
  PostQuitMessage(0);
  DeleteDC(tdc);
  DeleteObject(tbmp);
 end;
 procedure {_window.}establish(sx,sy,ssx,ssy:longint;title:pchar);
 begin
  resize(ssx,ssy);
  glaCreateWindow(sx,sy,ssx,ssy,title);
  glaBindFunc(WM_PAINT,@display);
  glaBindFunc(WM_DESTROY,@_destroy);
  
  glaBindFunc(WM_KEYDOWN,keydown);
  glaBindFunc(WM_KEYUP,keyup);
  glaBindFunc(WM_LBUTTONDOWN,lbuttondown);
  glaBindFunc(WM_RBUTTONDOWN,rbuttondown);
  glaBindFunc(WM_MBUTTONDOWN,mbuttondown);
  glaBindFunc(WM_LBUTTONUP,lbuttonup);
  glaBindFunc(WM_RBUTTONUP,rbuttonup);
  glaBindFunc(WM_MBUTTONUP,mbuttonup);
  //glaBindFunc(WM_,@);
  glaloop;
 end;
 procedure {_window.}resize(x,y:longint);
 var
  i:longint;
 begin
  setlength(map,x);
  for i:=0 to x-1 do
   setlength(map[i],y);
 end;
 procedure {_window.}redraw;
 begin
  display(0,0);
 end;
 procedure {_window.}display(wp,lp:dword);
 var
  i,j:longint;
  writer:tfpcustomimagewriter;
  img:tfpmemoryimage;
  px:tfpcolor;
 begin
  paint(wp,lp);
  if window_changed then
   begin
    writer:=tfpwriterbmp.create;
    img:=tfpmemoryimage.create(length(map),length(map[0]));
    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:=map[i,j].r*255;
         green:=map[i,j].g*255;
         blue:=map[i,j].b*255;
        end;
       img.colors[i,j]:=px;
      end;
    img.savetofile('cache.bmp',writer);
    img.destroy;
    if first_load then
     first_load:=false
    else
     DeleteObject(tbmp);
    tbmp:=LoadImage(0,'cache.bmp',IMAGE_BITMAP,length(map),length(map[0]),LR_LOADFROMFILE);
	SelectObject(tdc,tbmp);
	BitBlt(glaDC,0,0,length(map),length(map[0]),tdc,0,0,SRCCOPY);
    window_changed:=false;
   end
  else
   BitBlt(glaDC,0,0,length(map),length(map[0]),tdc,0,0,SRCCOPY);
 end;
 procedure {_window.}setpixel(x,y:longint;col:color3);
 begin
  if (col.r=map[x-1,y-1].r)and(col.g=map[x-1,y-1].g)and(col.b=map[x-1,y-1].b) then
   exit
  else
   begin
    window_changed:=true;
    map[x-1,y-1]:=col;
   end;
 end;
 function {_window.}getpixel(x,y:longint):color3;
 begin
  exit(map[x-1,y-1]);
 end;
 function make_color(r,g,b:longint):color3;
 begin
  make_color.r:=r;
  make_color.g:=g;
  make_color.b:=b;
 end;
begin
 glaInit;
end.

uses pixel2,sysutils;
var
 fps:longint;
 time:extended;
 procedure display(wp,lp:dword);
 var
  i,j:longint;
 begin
  for i:=1 to 400 do
   for j:=1 to 400 do
    if(i>40)or(j>40) then
     setpixel(i,j,make_color(random(256),random(256),random(256)))
    else
     if(i=j)or(i+j=41) then
      setpixel(i,j,make_color(255,0,0))
     else
      setpixel(i,j,make_color(255,255,255));
  fps:=fps+1;
  if (now-time)*86400>=1 then
   begin
    writeln(fps);
    fps:=0;
    time:=now;
   end;
 end;
 procedure click(wp,lp:longword);
 var
  x,y:longint;
 begin
  x:=lp mod 65536;
  y:=lp div 65536;
  if(x<=40)and(y<=40)then
   destroy;
 end;
begin
 time:=now;
 randomize;
 create;
 paint:=@display;
 lbuttondown:=@click;
 establish(100,100,400,400,'test');
end.