加入 Gitee
与超过 1200万 开发者一起发现、参与优秀开源项目,私有仓库也完全免费 :)
免费加入
文件
该仓库未声明开源许可证文件(LICENSE),使用请关注具体项目描述及其代码上游依赖。
克隆/下载
gla_base.inc 2.55 KB
一键复制 编辑 原始数据 按行查看 历史
FPC5719 提交于 2022-02-07 15:58 . 阶段性初始化提交
{
GLA中的基本窗口操作函数
}
{$IFDEF GLA_INTERFACE}
{$IFDEF GLA_DEBUG}
{$INFO Compiling gla_base::interface}
{$ENDIF}
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 glaFlush;
{$ENDIF}
{$IFDEF GLA_IMPLEMENTATION}
{$IFDEF GLA_DEBUG}
{$INFO Compiling gla_base::inplementation}
{$ENDIF}
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;
procedure __EnableOpenGL(var hw,dc,rc:DWord);
var
pfd:PIXELFORMATDESCRIPTOR;
iFormat:longint;
begin
dc:=GetDC(hw);
FillChar(pfd,sizeof(pfd),0);
pfd.nSize:=sizeof(pfd);
pfd.nVersion:=1;
pfd.dwFlags:=PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL or PFD_DOUBLEBUFFER;
pfd.iPixelType:=PFD_TYPE_RGBA;
pfd.cColorBits:=24;
pfd.cDepthBits:=16;
pfd.iLayerType:=PFD_MAIN_PLANE;
iFormat:=ChoosePixelFormat(dc,pfd);
SetPixelFormat(dc,iFormat,@pfd);
rc:=wglCreateContext(dc);
wglMakeCurrent(dc,rc);
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,dc,rc:DWord;
begin
hw:=CreateWindow(GLACLASSNAME,s,WS_OVERLAPPEDWINDOW,x,y,
w,h,0,0,system.MainInstance,NIL);
__hw:=hw;
if hw<>0 then begin
__EnableOpenGL(hw,dc,rc);
__dc:=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 glaFlush;
begin
SwapBuffers(__dc);
end;
{$ENDIF}
Loading...
马建仓 AI 助手
尝试更多
代码解读
代码找茬
代码优化