dima/kam-mobile
1
0 Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

sync: restore source from Google Drive
Sync changed files to Google Drive / sync (push) Successful in 1h45m13s
Details

Browse Source
This commit is contained in:
admin_d committed 2026-09-12 16:50:30 +05:00
1 parent e2d8247e91
commit 7063d1b1c9
993 files changed
+949976
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

vendor/kam_remake/src/ext/LazarusOpenGL/glcarbonaglcontext.pas
Vendored
+312
View File
@@ -0,0 +1,312 @@
{
*****************************************************************************
* *
* See the file COPYING.modifiedLGPL.txt, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
Author: Mattias Gaertner
}
unit GLCarbonAGLContext;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LCLProc, LCLType, gl, Forms,
MacOSAll,
AGL, CarbonProc, CarbonDef, CarbonPrivate,
WSLCLClasses, CarbonWSControls, CarbonUtils,
Controls;
procedure LOpenGLViewport(Left, Top, Width, Height: integer);
procedure LOpenGLSwapBuffers(Handle: HWND);
function LOpenGLMakeCurrent(Handle: HWND): boolean;
procedure LOpenGLClip(Handle: HWND);
function LOpenGLCreateContext(AWinControl: TWinControl;
{%H-}WSPrivate: TWSPrivateClass; SharedControl: TWinControl;
DoubleBuffered, RGBA: boolean;
const {%H-}AParams: TCreateParams): HWND;
procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl);
function CreateOpenGLContextAttrList(DoubleBuffered: boolean;
RGBA: boolean): PInteger;
type
TAGLControlInfo = record
Control: ControlRef;
WinControl: TWinControl;
AGLContext: TAGLContext;
end;
PAGLControlInfo = ^TAGLControlInfo;
var
AGLControlInfo_FOURCC: FourCharCode;
function CreateAGLControlInfo(Control: ControlRef; AGLContext: TAGLContext;
WinControl: TWinControl): PAGLControlInfo;
function GetAGLControlInfo(Control: ControlRef): PAGLControlInfo;
procedure FreeAGLControlInfo(Control: ControlRef);
function GetAGLContext(Control: ControlRef): TAGLContext;
implementation
procedure LOpenGLViewport(Left, Top, Width, Height: integer);
begin
glViewport(Left,Top,Width,Height);
end;
procedure LOpenGLSwapBuffers(Handle: HWND);
var
AGLContext: TAGLContext;
begin
AGLContext:=GetAGLContext(ControlRef(Handle));
aglSwapBuffers(AGLContext);
end;
function LOpenGLMakeCurrent(Handle: HWND): boolean;
var
AGLContext: TAGLContext;
Info: PAGLControlInfo;
Control: TCarbonCustomControl;
begin
Control:=TCarbonCustomControl(Handle);
Info:=GetAGLControlInfo(Control.Widget);
if Info=nil then exit;
AGLContext:=Info^.AGLContext;
Result:=aglSetCurrentContext(AGLContext)<>0;
end;
procedure LOpenGLClip(Handle: HWND);
var
AGLContext: TAGLContext;
Info: PAGLControlInfo;
Form: TCustomForm;
Win: WindowRef;
//b: Rect;
clipRgn: RgnHandle;
Control: TCarbonCustomControl;
begin
Control:=TCarbonCustomControl(Handle);
Info:=GetAGLControlInfo(Control.Widget);
debugln(['LOpenGLMakeCurrent AAA0']);
if Info=nil then exit;
AGLContext:=Info^.AGLContext;
aglSetCurrentContext(AGLContext);
debugln(['LOpenGLMakeCurrent AAA1 ',dbgs(Handle)]);
debugln(['LOpenGLMakeCurrent AAA2']);
Form:=GetParentForm(Info^.WinControl);
debugln(['LOpenGLMakeCurrent AAA3']);
Win:=TCarbonWindow(Form.Handle).Window;
debugln(['LOpenGLMakeCurrent ']);
//GetWindowPortBounds(Win,b);
clipRgn:=NewRgn;
SetRectRgn(clipRgn,10,10,100,100);
aglSetInteger(TAGLContext(GetWRefCon(Win)),AGL_CLIP_REGION,clipRgn);
aglEnable(TAGLContext(GetWRefCon(Win)),AGL_CLIP_REGION);
DisposeRgn(clipRgn);
end;
procedure ResizeOGLControl(AWidget: TCarbonWidget);
var
info : PAGLControlInfo;
r : array [0..3] of Integer;
bnd : HIRect;
str : MacOSAll.Rect;
win : WindowRef;
begin
info:=GetAGLControlInfo(AWidget.Widget);
if not Assigned(info) then Exit;
win:=HIViewGetWindow(AWidget.Widget);
if not Assigned(win) then Exit;
GetWindowBounds(win, kWindowStructureRgn, str);
HIViewGetBounds(AWidget.Widget, bnd);
HIViewConvertPoint(bnd.origin, AWidget.Widget, nil);
r[0]:=Round(bnd.origin.x);
r[1]:=Round((str.bottom-str.top)- bnd.origin.y-bnd.size.height);
r[2]:=Round(bnd.size.width);
r[3]:=Round(bnd.size.height);
aglEnable(info^.aglContext, AGL_BUFFER_RECT);
aglSetInteger(info^.aglContext, AGL_BUFFER_RECT, @r[0]);
end;
function CarbonGLControl_Resize(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
begin
Result:=CallNextEventHandler(ANextHandler, AEvent);
ResizeOGLControl(AWidget);
end;
function CarbonGLControl_WindowChange(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
var
win : WindowRef;
begin
Result:=CallNextEventHandler(ANextHandler, AEvent);
if GetEventParameter(AEvent, kEventParamControlCurrentOwningWindow, typeWindowRef,
nil, sizeof(win), nil, @win) = noErr then
if Assigned(win) then ResizeOGLControl(AWidget);
end;
function LOpenGLCreateContext(AWinControl: TWinControl;
WSPrivate: TWSPrivateClass; SharedControl: TWinControl;
DoubleBuffered, RGBA: boolean;
const AParams: TCreateParams): HWND;
var
disp: GDHandle;
aglPixFmt: TAGLPixelFormat;
aglContext: TAGLContext;
Control: TCarbonCustomControl;
AttrList: PInteger;
C: TCreateParams;
AGLInfo: PAGLControlInfo;
TempSpec: EventTypeSpec;
begin
Result:=0;
if AWinControl.Parent=nil then
RaiseGDBException('GLCarbonAGLContext.LOpenGLCreateContext no parent');
C.X := AWinControl.Left;
C.Y := AWinControl.Top;
C.Width := AWinControl.Width;
C.Height := AWinControl.Height;
// create a custom control
Control := TCarbonCustomControl.Create(AWinControl, C);
//debugln(['LOpenGLCreateContext ',dbgsName(Control)]);
// create the AGL context
disp := GetMainDevice ();
AttrList:=CreateOpenGLContextAttrList(DoubleBuffered,RGBA);
aglPixFmt := aglChoosePixelFormat (@disp, 1, AttrList);
System.FreeMem(AttrList);
aglContext := aglCreateContext (aglPixFmt, NIL);
aglDestroyPixelFormat(aglPixFmt);
aglSetDrawable(aglContext,
GetWindowPort(TCarbonWindow(GetParentForm(AWinControl).Handle).Window));
AGLControlInfo_FOURCC := MakeFourCC('ACI ');
AGLInfo:=CreateAGLControlInfo(Control.Widget, AGLContext, AWinControl);
if AGLInfo<>GetAGLControlInfo(Control.Widget) then
RaiseGDBException('GLCarbonAGLContext.LOpenGLCreateContext inconsistency');
ResizeOGLControl(Control);
TempSpec:=MakeEventSpec(kEventClassControl, kEventControlBoundsChanged);
InstallControlEventHandler(Control.Widget, RegisterEventHandler(@CarbonGLControl_Resize),
1, @TempSpec, Control, nil);
TempSpec:=MakeEventSpec(kEventClassControl, kEventControlOwningWindowChanged);
// The control might be embeded into a window, after the its creation
// the example of the situation is give at bug report #17244
InstallControlEventHandler(Control.Widget, RegisterEventHandler(@CarbonGLControl_WindowChange),
1, @TempSpec, Control, nil);
Result:=HWnd(Control);
//debugln(['LOpenGLCreateContext ',dbgs(Result)]);
end;
procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl);
var
Ref: ControlRef;
Info: PAGLControlInfo;
begin
if not AWinControl.HandleAllocated then exit;
Ref := ControlRef(TCarbonControl(AWinControl.Handle).Widget);
Info := GetAGLControlInfo(Ref);
if Info=nil then exit;
aglDestroyContext(Info^.AGLContext);
Info^.AGLContext := nil;
FreeAGLControlInfo(Ref);
end;
function CreateOpenGLContextAttrList(DoubleBuffered: boolean; RGBA: boolean
): PInteger;
var
p: integer;
procedure Add(i: integer);
begin
if Result<>nil then
Result[p]:=i;
inc(p);
end;
procedure CreateList;
begin
Add(AGL_WINDOW);
if DoubleBuffered then
Add(AGL_DOUBLEBUFFER);
if RGBA then
Add(AGL_RGBA);
Add(AGL_NO_RECOVERY);
Add(AGL_MAXIMUM_POLICY);
Add(AGL_SINGLE_RENDERER);
Add(AGL_RED_SIZE); Add(1);
Add(AGL_GREEN_SIZE); Add(1);
Add(AGL_BLUE_SIZE); Add(1);
Add(AGL_DEPTH_SIZE); Add(1);
Add(AGL_NONE);
end;
begin
Result:=nil;
p:=0;
CreateList;
GetMem(Result,SizeOf(integer)*p);
p:=0;
CreateList;
end;
function CreateAGLControlInfo(Control: ControlRef; AGLContext: TAGLContext;
WinControl: TWinControl): PAGLControlInfo;
begin
New(Result);
FillByte(Result^, SizeOf(Result^), 0);
Result^.Control:=Control;
Result^.WinControl:=WinControl;
Result^.AGLContext:=AGLContext;
SetControlProperty(Control, LAZARUS_FOURCC, AGLControlInfo_FOURCC,
SizeOf(Result), @Result);
end;
function GetAGLControlInfo(Control: ControlRef): PAGLControlInfo;
var
m: LongWord;
begin
GetControlProperty(Control, LAZARUS_FOURCC, AGLControlInfo_FOURCC,
SizeOf(Result), @m, @Result);
end;
procedure FreeAGLControlInfo(Control: ControlRef);
var
Info: PAGLControlInfo;
begin
Info:=GetAGLControlInfo(Control);
if Info=nil then exit;
RemoveControlProperty(Control, LAZARUS_FOURCC, AGLControlInfo_FOURCC);
System.FreeMem(Info);
end;
function GetAGLContext(Control: ControlRef): TAGLContext;
begin
Result:=GetAGLControlInfo(TCarbonCustomControl(Control).Widget)^.AGLContext;
end;
initialization
finalization
end.
vendor/kam_remake/src/ext/LazarusOpenGL/glgtkglxcontext.pas
Vendored
+835
View File
@@ -0,0 +1,835 @@
{
*****************************************************************************
* *
* See the file COPYING.modifiedLGPL.txt, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
Author: Mattias Gaertner
}
unit GLGtkGlxContext;
{$mode objfpc}{$H+}
{$LinkLib GL}
{$PACKRECORDS C}
interface
uses
Classes, SysUtils, LCLProc, LCLType, X, XUtil, XLib, gl, InterfaceBase,
WSLCLClasses,
{$IFDEF LCLGTK2}
LMessages, Gtk2Def, gdk2x, glib2, gdk2, gtk2, Gtk2Int,
{$ENDIF}
{$IFDEF LCLGTK}
glib, gdk, gtk, GtkInt,
{$ENDIF}
Controls;
// gdkgl
const
// enum _GDK_GL_CONFIGS
GDK_GL_NONE = 0;
GDK_GL_USE_GL = 1;
GDK_GL_BUFFER_SIZE = 2;
GDK_GL_LEVEL = 3;
GDK_GL_RGBA = 4;
GDK_GL_DOUBLEBUFFER = 5;
GDK_GL_STEREO = 6;
GDK_GL_AUX_BUFFERS = 7;
GDK_GL_RED_SIZE = 8;
GDK_GL_GREEN_SIZE = 9;
GDK_GL_BLUE_SIZE = 10;
GDK_GL_ALPHA_SIZE = 11;
GDK_GL_DEPTH_SIZE = 12;
GDK_GL_STENCIL_SIZE = 13;
GDK_GL_ACCUM_RED_SIZE = 14;
GDK_GL_ACCUM_GREEN_SIZE = 15;
GDK_GL_ACCUM_BLUE_SIZE = 16;
GDK_GL_ACCUM_ALPHA_SIZE = 17;
// GLX_EXT_visual_info extension
GDK_GL_X_VISUAL_TYPE_EXT = $22;
GDK_GL_TRANSPARENT_TYPE_EXT = $23;
GDK_GL_TRANSPARENT_INDEX_VALUE_EXT = $24;
GDK_GL_TRANSPARENT_RED_VALUE_EXT = $25;
GDK_GL_TRANSPARENT_GREEN_VALUE_EXT = $26;
GDK_GL_TRANSPARENT_BLUE_VALUE_EXT = $27;
GDK_GL_TRANSPARENT_ALPHA_VALUE_EXT = $28;
type
TGdkGLContext = record end;
PGdkGLContext = ^TGdkGLContext;
// GLX_EXT_visual_info extension
function gdk_gl_query: boolean;
function gdk_gl_choose_visual(attrlist: Plongint): PGdkVisual;
function gdk_gl_get_config(visual: PGdkVisual; attrib: longint): longint;
function gdk_gl_context_new(visual: PGdkVisual; attrlist: PlongInt): PGdkGLContext;
function gdk_gl_context_share_new(visual: PGdkVisual; sharelist: PGdkGLContext;
direct: TBool; attrlist: plongint): PGdkGLContext;
function gdk_gl_context_attrlist_share_new(attrlist: Plongint;
sharelist: PGdkGLContext; direct: TBool): PGdkGLContext;
function gdk_gl_context_ref(context: PGdkGLContext): PGdkGLContext;
procedure gdk_gl_context_unref(context:PGdkGLContext);
function gdk_gl_make_current(drawable: PGdkDrawable;
context: PGdkGLContext): boolean;
procedure gdk_gl_swap_buffers(drawable: PGdkDrawable);
procedure gdk_gl_wait_gdk;
procedure gdk_gl_wait_gl;
{ glpixmap stuff }
type
TGdkGLPixmap = record end;
PGdkGLPixmap = ^TGdkGLPixmap;
TGLXContext = pointer;
// gtkglarea
type
TGtkGlAreaMakeCurrentType = boolean;
PGtkGLArea = ^TGtkGLArea;
TGtkGLArea = record
darea: TGtkDrawingArea;
glcontext: PGdkGLContext;
end;
PGtkGLAreaClass = ^TGtkGLAreaClass;
TGtkGLAreaClass = record
parent_class: TGtkDrawingAreaClass;
end;
function GTK_TYPE_GL_AREA: TGtkType;
function GTK_GL_AREA(obj: Pointer): PGtkGLArea;
function GTK_GL_AREA_CLASS(klass: Pointer): PGtkGLAreaClass;
function GTK_IS_GL_AREA(obj: Pointer): Boolean;
function GTK_IS_GL_AREA_CLASS(klass: Pointer): Boolean;
function gtk_gl_area_get_type: TGtkType;
function gtk_gl_area_new(attrList: Plongint): PGtkWidget;
function gtk_gl_area_share_new(attrList: Plongint; share: PGtkGLArea): PGtkWidget;
function gtk_gl_area_make_current(glarea: PGtkGLArea): boolean;
function gtk_gl_area_begingl(glarea: PGtkGLArea): boolean;
procedure gtk_gl_area_swap_buffers(gl_area: PGtkGLArea);
procedure LOpenGLViewport(Left, Top, Width, Height: integer);
procedure LOpenGLSwapBuffers(Handle: HWND);
function LOpenGLMakeCurrent(Handle: HWND): boolean;
function LOpenGLCreateContext(AWinControl: TWinControl;
WSPrivate: TWSPrivateClass; SharedControl: TWinControl;
DoubleBuffered, RGBA: boolean;
const AParams: TCreateParams): HWND;
procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl);
function CreateOpenGLContextAttrList(DoubleBuffered: boolean;
RGBA: boolean): PInteger;
implementation
var
gl_area_type: TGtkType = 0;
parent_class: Pointer = nil;
type
TGdkGLContextPrivate = record
xdisplay: PDisplay;
glxcontext: TGLXContext;
ref_count: gint;
end;
PGdkGLContextPrivate = ^TGdkGLContextPrivate;
type
//PGLXPixmap = ^GLXPixmap;
GLXPixmap = TXID;
//PGLXDrawable = ^GLXDrawable;
GLXDrawable = TXID;
{ GLX 1.0 functions. }
function glXChooseVisual(dpy:PDisplay; screen:longint; attrib_list:Plongint):PXVisualInfo;cdecl;external;
procedure glXCopyContext(dpy:PDisplay; src:TGLXContext; dst:TGLXContext; mask: cardinal);cdecl;external;
function glXCreateContext(dpy:PDisplay; vis:PXVisualInfo; share_list:TGLXContext; direct:TBool):TGLXContext;cdecl;external;
function glXCreateGLXPixmap(dpy:PDisplay; vis:PXVisualInfo; pixmap:TPixmap):GLXPixmap;cdecl;external;
procedure glXDestroyContext(dpy:PDisplay; ctx:TGLXContext);cdecl;external;
procedure glXDestroyGLXPixmap(dpy:PDisplay; pix:GLXPixmap);cdecl;external;
function glXGetConfig(dpy:PDisplay; vis:PXVisualInfo; attrib:longint; value:Plongint):longint;cdecl;external;
function glXGetCurrentContext:TGLXContext;cdecl;external;
function glXGetCurrentDrawable:GLXDrawable;cdecl;external;
function glXIsDirect(dpy:PDisplay; ctx:TGLXContext):TBool;cdecl;external;
function glXMakeCurrent(dpy:PDisplay; drawable:GLXDrawable; ctx:TGLXContext):TBool;cdecl;external;
function glXQueryExtension(dpy:PDisplay; error_base:Plongint; event_base:Plongint):TBool;cdecl;external;
function glXQueryVersion(dpy:PDisplay; major:Plongint; minor:Plongint):TBool;cdecl;external;
procedure glXSwapBuffers(dpy:PDisplay; drawable:GLXDrawable);cdecl;external;
procedure glXUseXFont(font:TFont; first:longint; count:longint; list_base:longint);cdecl;external;
procedure glXWaitGL;cdecl;external;
procedure glXWaitX;cdecl;external;
procedure g_return_if_fail(b: boolean; const Msg: string);
begin
if not b then raise Exception.Create(Msg);
end;
procedure g_return_if_fail(b: boolean);
begin
g_return_if_fail(b,'');
end;
function DefaultScreen(ADisplay: PDisplay): longint;
begin
Result:=XDefaultScreen(ADisplay);
end;
function g_new(BaseSize, Count: integer): Pointer;
begin
Result:=g_malloc(BaseSize*Count);
end;
function GetDefaultXDisplay: PDisplay;
begin
Result:=GDK_DISPLAY;
end;
{$IFDEF LCLGtk2}
function GdkVisualAsString(Visual: PGdkVisual): string;
begin
if Visual=nil then begin
Result:='nil';
end else begin
with Visual^ do begin
Result:=''
//parent_instance : TGObject;
+' TheType='+dbgs(ord(TheType))
+' depth='+dbgs(depth)
+' byte_order='+dbgs(ord(byte_order))
+' colormap_size='+dbgs(colormap_size)
+' bits_per_rgb='+dbgs(bits_per_rgb)
+' red_mask='+hexstr(red_mask,8)
+' red_shift='+dbgs(red_shift)
+' red_prec='+dbgs(red_prec)
+' green_mask='+hexstr(green_mask,8)
+' green_shift='+dbgs(green_shift)
+' green_prec='+dbgs(green_prec)
+' blue_mask='+hexstr(blue_mask,8)
+' blue_shift='+dbgs(blue_shift)
+' blue_prec='+dbgs(blue_prec)
//screen : PGdkScreen;
+'';
end;
end;
end;
function XVisualAsString(AVisual: PVisual): string;
begin
if AVisual=nil then begin
Result:='nil';
end else begin
Result:=''
+' bits_per_rgb='+dbgs(AVisual^.bits_per_rgb)
+' red_mask='+hexstr(AVisual^.red_mask,8)
+' green_mask='+hexstr(AVisual^.green_mask,8)
+' blue_mask='+hexstr(AVisual^.blue_mask,8)
+' map_entries='+dbgs(AVisual^.map_entries)
+'';
end;
end;
function XDisplayAsString(ADisplay: PDisplay): string;
begin
if ADisplay=nil then begin
Result:='nil';
end else begin
Result:=''
+'';
end;
end;
{$ENDIF}
function get_xvisualinfo(visual: PGdkVisual): PXVisualInfo;
// IMPORTANT: remember to XFree returned XVisualInfo !!!
var
vinfo_template: TXVisualInfo;
dpy: PDisplay;
nitems_return: integer;
vi: PXVisualInfo;
begin
dpy := GetDefaultXDisplay;
{$IFDEF Lclgtk2}
DebugLn('get_xvisualinfo dpy=',XDisplayAsString(dpy));
DebugLn('get_xvisualinfo visual=',GdkVisualAsString(Visual));
RaiseGDBException('not implemented for gtk2');
{$ENDIF}
// 'GLX uses VisualInfo records because they uniquely identify
// a (VisualID,screen,depth) tuple.'
vinfo_template.bits_per_rgb:=0;
FillChar(vinfo_template,SizeOf(vinfo_template),0);
vinfo_template.visual := GDK_VISUAL_XVISUAL({$IFDEF LCLGTK}
PGdkVisualPrivate(visual)
{$ELSE}
visual
{$ENDIF});
vinfo_template.visualid := XVisualIDFromVisual(vinfo_template.visual);
vinfo_template.depth := PGdkVisualPrivate(visual)^.visual.depth;
vinfo_template.screen := DefaultScreen(GetDefaultXDisplay);
{$IFDEF LCLGTK2}
DebugLn('get_xvisualinfo vinfo_template.visual=',dbgs(vinfo_template.visual));
DebugLn('get_xvisualinfo vinfo_template.visual: ',XVisualAsString(vinfo_template.visual));
DebugLn('get_xvisualinfo vinfo_template.visualid=',dbgs(vinfo_template.visualid));
DebugLn('get_xvisualinfo vinfo_template.depth=',dbgs(vinfo_template.depth),' GetDefaultXDisplay=',dbgs(GetDefaultXDisplay));
DebugLn('get_xvisualinfo vinfo_template.screen=',dbgs(vinfo_template.screen));
{$ENDIF}
vi := XGetVisualInfo(dpy, VisualIDMask or VisualDepthMask or VisualScreenMask,
@vinfo_template, @nitems_return);
DebugLn('get_xvisualinfo nitems_return=',dbgs(nitems_return));
// visualinfo needs to be unique
if (vi=nil) then raise Exception.Create('get_xvisualinfo vi=nil');
if (nitems_return<>1) then raise Exception.Create('get_xvisualinfo nitems_return='+dbgs(nitems_return));
Result:=vi;
end;
procedure gtk_gl_area_destroy(obj: PGtkObject); cdecl;
var
gl_area: PGtkGLArea;
begin
g_return_if_fail (obj <>nil,'');
g_return_if_fail (GTK_IS_GL_AREA(obj),'');
gl_area := GTK_GL_AREA(obj);
gdk_gl_context_unref(gl_area^.glcontext);
if Assigned(GTK_OBJECT_CLASS(parent_class)^.destroy) then
GTK_OBJECT_CLASS(parent_class)^.destroy(obj);
end;
procedure gtk_gl_area_class_init(klass: Pointer); cdecl;
var
object_class: PGtkObjectClass;
begin
parent_class := gtk_type_class(gtk_drawing_area_get_type());
g_return_if_fail(parent_class<>nil,'gtk_gl_area_class_init parent_class=nil');
object_class := PGtkObjectClass(klass);
g_return_if_fail(object_class<>nil,'gtk_gl_area_class_init object_class=nil');
object_class^.destroy := @gtk_gl_area_destroy;
end;
function gdk_gl_query: boolean;
begin
Result:=boolean(glXQueryExtension(GetDefaultXDisplay,nil,nil){$IFDEF VER2_2}=true{$ENDIF});
end;
function gdk_gl_choose_visual(attrlist: Plongint): PGdkVisual;
var
dpy: PDisplay;
vi: PXVisualInfo;
visual: PGdkVisual;
begin
{$IFDEF lclgtk2}
DebugLn(['gdk_gl_choose_visual not implemented yet for gtk2']);
RaiseGDBException('');
{$ENDIF}
if attrList=nil then begin
Result:=nil;
exit;
end;
dpy := GetDefaultXDisplay;
vi := glXChooseVisual(dpy,DefaultScreen(dpy), attrlist);
if (vi=nil) then begin
Result:=nil;
exit;
end;
visual := gdkx_visual_get(vi^.visualid);
XFree(vi);
Result:=visual;
end;
function gdk_gl_get_config(visual: PGdkVisual; attrib: longint): longint;
var
dpy: PDisplay;
vi: PXVisualInfo;
value: integer;
begin
Result:=-1;
if visual=nil then exit;
dpy := GetDefaultXDisplay;
vi := get_xvisualinfo(visual);
if (glXGetConfig(dpy, vi, attrib, @value) = 0) then begin
XFree(vi);
Result:=value;
end else
XFree(vi);
end;
function gdk_gl_context_new(visual: PGdkVisual; attrlist: PlongInt): PGdkGLContext;
begin
Result := gdk_gl_context_share_new(visual, nil,
{$IFDEF VER2_2}false{$ELSE}0{$ENDIF}, attrlist);
end;
function gdk_gl_context_share_new(visual: PGdkVisual; sharelist: PGdkGLContext;
direct: TBool; attrlist: plongint): PGdkGLContext;
var
dpy: PDisplay;
vi: PXVisualInfo;
PrivateShareList: PGdkGLContextPrivate;
PrivateContext: PGdkGLContextPrivate;
glxcontext: TGLXContext;
begin
Result:=nil;
dpy := GetDefaultXDisplay;
{$IFDEF lclgtk2}
if visual=nil then ;
vi:=glXChooseVisual(dpy, DefaultScreen(dpy), @attrList[0]);
{$ELSE}
if visual=nil then exit;
vi := get_xvisualinfo(visual);
{$ENDIF}
if vi=nil then
raise Exception.Create('gdk_gl_context_share_new no visual found');
PrivateShareList:=PGdkGLContextPrivate(sharelist);
if (sharelist<>nil) then
glxcontext := glXCreateContext(dpy, vi, PrivateShareList^.glxcontext,
direct)
else
glxcontext := glXCreateContext(dpy, vi, nil, direct);
XFree(vi);
if (glxcontext = nil) then exit;
PrivateContext := g_new(SizeOf(TGdkGLContextPrivate), 1);
PrivateContext^.xdisplay := dpy;
PrivateContext^.glxcontext := glxcontext;
PrivateContext^.ref_count := 1;
Result := PGdkGLContext(PrivateContext);
end;
function gdk_gl_context_attrlist_share_new(attrlist: Plongint;
sharelist: PGdkGLContext; direct: TBool): PGdkGLContext;
var
visual: PGdkVisual;
begin
{$IFDEF lclgtk2}
visual :=nil;
Result := gdk_gl_context_share_new(visual, sharelist, direct, attrlist);
{$ELSE}
visual := gdk_gl_choose_visual(attrlist);
if (visual <> nil) then
Result := gdk_gl_context_share_new(visual, sharelist, direct, attrlist)
else
Result := nil;
{$ENDIF}
end;
function gdk_gl_context_ref(context: PGdkGLContext): PGdkGLContext;
var
PrivateContext: PGdkGLContextPrivate;
begin
Result:=nil;
if context=nil then exit;
PrivateContext := PGdkGLContextPrivate(context);
inc(PrivateContext^.ref_count);
//DebugLn(['gdk_gl_context_ref ref_count=',PrivateContext^.ref_count]);
Result:=context;
end;
procedure gdk_gl_context_unref(context: PGdkGLContext);
var
PrivateContext: PGdkGLContextPrivate;
begin
g_return_if_fail(context<>nil,'');
PrivateContext:=PGdkGLContextPrivate(context);
dec(PrivateContext^.ref_count);
if (PrivateContext^.ref_count = 0) then begin
//DebugLn(['gdk_gl_context_unref START ref_count=',PrivateContext^.ref_count]);
if (PrivateContext^.glxcontext = glXGetCurrentContext()) then
glXMakeCurrent(PrivateContext^.xdisplay, None, nil);
glXDestroyContext(PrivateContext^.xdisplay, PrivateContext^.glxcontext);
PrivateContext^.glxcontext:=nil;
g_free(PrivateContext);
//DebugLn(['gdk_gl_context_unref END']);
end;
end;
function gdk_gl_make_current(drawable: PGdkDrawable;
context: PGdkGLContext): boolean;
var
PrivateContext: PGdkGLContextPrivate;
begin
Result:=false;
if drawable=nil then exit;
if context=nil then exit;
PrivateContext := PGdkGLContextPrivate(context);
Result:=boolean(glXMakeCurrent(PrivateContext^.xdisplay,
{$IFDEF LCLGTK}
GDK_WINDOW_XWINDOW(PGdkWindowPrivate(drawable)),
{$ELSE}
GDK_WINDOW_XWINDOW(drawable),
{$ENDIF}
PrivateContext^.glxcontext)
{$IFDEF VER2_2}=true{$ENDIF});
end;
procedure gdk_gl_swap_buffers(drawable: PGdkDrawable);
begin
g_return_if_fail(drawable <> nil);
glXSwapBuffers({$IFDEF LCLGTK}
GDK_WINDOW_XDISPLAY(PGdkWindowPrivate(drawable)),
GDK_WINDOW_XWINDOW(PGdkWindowPrivate(drawable))
{$ELSE}
GDK_WINDOW_XDISPLAY(drawable),
GDK_WINDOW_XWINDOW(drawable)
{$ENDIF}
);
end;
procedure gdk_gl_wait_gdk;
begin
glXWaitX;
end;
procedure gdk_gl_wait_gl;
begin
glXWaitGL;
end;
procedure gtk_gl_area_init(
{$IFDEF LCLGTK}
gl_area, theClass: Pointer
{$ELSE}
gl_area: PGTypeInstance; theClass: gpointer
{$ENDIF}
); cdecl;
begin
if theClass=nil then ;
//DebugLn(['gtk_gl_area_init START']);
PGtkGLArea(gl_area)^.glcontext:=nil;
{$IFDEF LclGtk2}
gtk_widget_set_double_buffered(PGtkWidget(gl_area),gdkFALSE);
GTK_WIDGET_UNSET_FLAGS(PGtkWidget(gl_area),GTK_NO_WINDOW);
{$ENDIF}
//DebugLn(['gtk_gl_area_init END']);
end;
function GTK_TYPE_GL_AREA: TGtkType;
const
gl_area_type_name = 'GtkGLArea';
gl_area_info: TGtkTypeInfo = (
type_name: gl_area_type_name;
object_size: SizeOf(TGtkGLArea);
class_size: SizeOf(TGtkGLAreaClass);
class_init_func: @gtk_gl_area_class_init;
object_init_func: @gtk_gl_area_init;
reserved_1: nil;
reserved_2: nil;
base_class_init_func: nil;
);
begin
if (gl_area_type=0) then begin
gl_area_type:=gtk_type_unique(gtk_drawing_area_get_type(),@gl_area_info);
end;
Result:=gl_area_type;
end;
function GTK_GL_AREA(obj: Pointer): PGtkGLArea;
begin
g_return_if_fail(GTK_IS_GL_AREA(obj),'');
Result:=PGtkGLArea(obj);
end;
function GTK_GL_AREA_CLASS(klass: Pointer): PGtkGLAreaClass;
begin
g_return_if_fail(GTK_IS_GL_AREA_CLASS(klass),'');
Result:=PGtkGLAreaClass(klass);
end;
function GTK_IS_GL_AREA(obj: Pointer): Boolean;
begin
{$IFDEF LCLGTK}
Result := Assigned(obj) and GTK_IS_GL_AREA_CLASS(PGtkTypeObject(obj)^.klass);
{$ELSE}
GTK_IS_GL_AREA:=GTK_CHECK_TYPE(obj,GTK_TYPE_GL_AREA);
{$ENDIF}
end;
function GTK_IS_GL_AREA_CLASS(klass: Pointer): Boolean;
begin
{$IFDEF LCLGTK}
Result := Assigned(klass) and (PGtkTypeClass(klass)^.thetype = GTK_TYPE_GL_AREA);
{$ELSE}
GTK_IS_GL_AREA_CLASS:=GTK_CHECK_CLASS_TYPE(klass,GTK_TYPE_GL_AREA);
{$ENDIF}
end;
function gtk_gl_area_get_type: TGtkType;
begin
Result:=GTK_TYPE_GL_AREA;
end;
function gtk_gl_area_new(attrList: Plongint): PGtkWidget;
var
Count: Integer;
CopyAttrList: Plongint;
Size: Integer;
begin
Count:=0;
while (attrList[Count]<>GDK_GL_NONE) do inc(Count);
inc(Count);
Size:=SizeOf(Integer)*Count;
CopyAttrList:=nil;
GetMem(CopyAttrList,Size);
System.Move(attrList^,CopyAttrList^,Size);
Result:=gtk_gl_area_share_new(CopyAttrList,nil);
FreeMem(CopyAttrList);
end;
function gtk_gl_area_share_new(attrList: Plongint; share: PGtkGLArea
): PGtkWidget;
var
visual: PGdkVisual;
sharelist: PGdkGLContext;
glcontext: PGdkGLContext;
gl_area: PGtkGLArea;
begin
Result := nil;
//DebugLn(['gtk_gl_area_share_new START']);
if (share <> nil) and (not GTK_IS_GL_AREA(share)) then
exit;
{$IFNDEF MSWindows}
{$IFDEF lclgtk2}
visual := nil;
{$ELSE}
visual := gdk_gl_choose_visual(attrlist);
if (visual = nil) then exit;
{$ENDIF}
{$ENDIF non MSWindows}
sharelist := nil;
if share <> nil then sharelist := share^.glcontext;
glcontext := gdk_gl_context_share_new(visual, sharelist,
{$IFDEF VER2_2}true{$ELSE}1{$ENDIF}, attrlist);
if (glcontext = nil) then exit;
{$IFNDEF MSWindows}
if visual <> nil then begin
// use colormap and visual suitable for OpenGL rendering
gtk_widget_push_colormap(gdk_colormap_new(visual, gtk_TRUE));
gtk_widget_push_visual(visual);
end;
{$ENDIF non MSWindows}
gl_area := gtk_type_new (gtk_gl_area_get_type);
gl_area^.glcontext := glcontext;
{$IFNDEF MSWindows}
if visual<>nil then begin
// pop back defaults
gtk_widget_pop_visual;
gtk_widget_pop_colormap;
end;
{$ENDIF non MSWindows}
Result:=PGtkWidget(gl_area);
end;
function gtk_gl_area_make_current(glarea: PGtkGLArea): boolean;
begin
Result:=false;
if glarea=nil then exit;
if not GTK_IS_GL_AREA(glarea) then exit;
if not GTK_WIDGET_REALIZED(PGtkWidget(glarea)) then exit;
//DebugLn(['gtk_gl_area_make_current START']);
Result:=gdk_gl_make_current(PGtkWidget(glarea)^.window, glarea^.glcontext);
//DebugLn(['gtk_gl_area_make_current END']);
end;
function gtk_gl_area_begingl(glarea: PGtkGLArea): boolean;
begin
Result:=gtk_gl_area_make_current(glarea);
end;
procedure gtk_gl_area_swap_buffers(gl_area: PGtkGLArea);
begin
g_return_if_fail(gl_area <> nil);
g_return_if_fail(GTK_IS_GL_AREA(gl_area));
g_return_if_fail(GTK_WIDGET_REALIZED(PGtkWidget(gl_area)));
gdk_gl_swap_buffers(GTK_WIDGET(gl_area)^.window);
end;
procedure LOpenGLViewport(Left, Top, Width, Height: integer);
begin
glViewport(Left,Top,Width,Height);
end;
procedure LOpenGLSwapBuffers(Handle: HWND);
begin
gtk_gl_area_swap_buffers({%H-}PGtkGLArea(Handle));
end;
function LOpenGLMakeCurrent(Handle: HWND): boolean;
var
Widget: PGtkWidget;
glarea: PGtkGLArea;
begin
if Handle=0 then
RaiseGDBException('LOpenGLSwapBuffers Handle=0');
Result:=false;
Widget:={%H-}PGtkWidget(PtrUInt(Handle));
glarea:=PGtkGLArea(Widget);
if not GTK_IS_GL_AREA(glarea) then
RaiseGDBException('LOpenGLSwapBuffers not a PGtkGLArea');
// make sure the widget is realized
gtk_widget_realize(Widget);
if not GTK_WIDGET_REALIZED(Widget) then exit;
// make current
Result:=gtk_gl_area_make_current(glarea);
end;
{$IFDEF LCLGtk2}
function gtkglarea_size_allocateCB(Widget: PGtkWidget; Size: pGtkAllocation;
Data: gPointer): GBoolean; cdecl;
const
CallBackDefaultReturn = {$IFDEF GTK2}false{$ELSE}true{$ENDIF};
var
SizeMsg: TLMSize;
GtkWidth, GtkHeight: integer;
LCLControl: TWinControl;
begin
Result := CallBackDefaultReturn;
if not GTK_WIDGET_REALIZED(Widget) then begin
// the widget is not yet realized, so this GTK resize was not a user change.
// => ignore
exit;
end;
if Size=nil then ;
LCLControl:=TWinControl(Data);
if LCLControl=nil then exit;
//DebugLn(['gtkglarea_size_allocateCB ',DbgSName(LCLControl)]);
gtk_widget_get_size_request(Widget, @GtkWidth, @GtkHeight);
SizeMsg.Msg:=0;
FillChar(SizeMsg,SizeOf(SizeMsg),0);
with SizeMsg do
begin
Result := 0;
Msg := LM_SIZE;
SizeType := Size_SourceIsInterface;
Width := SmallInt(GtkWidth);
Height := SmallInt(GtkHeight);
end;
//DebugLn(['gtkglarea_size_allocateCB ',GtkWidth,',',GtkHeight]);
LCLControl.WindowProc(TLMessage(SizeMsg));
end;
{$ENDIF}
function LOpenGLCreateContext(AWinControl: TWinControl;
WSPrivate: TWSPrivateClass; SharedControl: TWinControl;
DoubleBuffered, RGBA: boolean;
const AParams: TCreateParams): HWND;
var
NewWidget: PGtkWidget;
SharedArea: PGtkGLArea;
AttrList: PInteger;
begin
if WSPrivate=nil then ;
AttrList:=CreateOpenGLContextAttrList(DoubleBuffered,RGBA);
try
if SharedControl<>nil then begin
SharedArea:={%H-}PGtkGLArea(PtrUInt(SharedControl.Handle));
if not GTK_IS_GL_AREA(SharedArea) then
RaiseGDBException('LOpenGLCreateContext');
NewWidget:=gtk_gl_area_share_new(AttrList,SharedArea);
end else begin
NewWidget:=gtk_gl_area_new(AttrList);
end;
Result:=HWND({%H-}PtrUInt(Pointer(NewWidget)));
PGtkobject(NewWidget)^.flags:=PGtkobject(NewWidget)^.flags or GTK_CAN_FOCUS;
{$IFDEF LCLGtk}
TGTKWidgetSet(WidgetSet).FinishCreateHandle(AWinControl,NewWidget,AParams);
{$ELSE}
TGTK2WidgetSet(WidgetSet).FinishCreateHandle(AWinControl,NewWidget,AParams);
g_signal_connect_after(PGtkObject(NewWidget), 'size-allocate',
TGTKSignalFunc(@gtkglarea_size_allocateCB), AWinControl);
{$ENDIF}
finally
FreeMem(AttrList);
end;
end;
procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl);
begin
if not AWinControl.HandleAllocated then exit;
// nothing to do
end;
function CreateOpenGLContextAttrList(DoubleBuffered: boolean; RGBA: boolean
): PInteger;
var
p: integer;
procedure Add(i: integer);
begin
if Result<>nil then
Result[p]:=i;
inc(p);
end;
procedure CreateList;
begin
if DoubleBuffered then
Add(GDK_GL_DOUBLEBUFFER);
if RGBA then
Add(GDK_GL_RGBA);
Add(GDK_GL_RED_SIZE); Add(1);
Add(GDK_GL_GREEN_SIZE); Add(1);
Add(GDK_GL_BLUE_SIZE); Add(1);
Add(GDK_GL_DEPTH_SIZE); Add(1);
Add(GDK_GL_STENCIL_SIZE); Add(1);
Add(GDK_GL_None);
end;
begin
Result:=nil;
p:=0;
CreateList;
GetMem(Result,SizeOf(integer)*p);
p:=0;
CreateList;
end;
end.
vendor/kam_remake/src/ext/LazarusOpenGL/glqtcontext.pas
Vendored
+255
View File
@@ -0,0 +1,255 @@
{
*****************************************************************************
* *
* See the file COPYING.modifiedLGPL.txt, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
Author: Mattias Gaertner
}
unit GLQTContext;
{$mode objfpc}{$H+}
{$LinkLib GL}
{$PACKRECORDS C}
interface
uses
Classes, SysUtils, Controls, LCLProc, LCLType, X, XUtil, XLib, gl,
InterfaceBase,
WSLCLClasses,
// Bindings
qt4,
qtwidgets, qtobjects, qtproc, qtint,
QtWSControls;
// gdkgl
const
// enum _QT_GL_CONFIGS
QT_GL_NONE = 0;
QT_GL_USE_GL = 1;
QT_GL_BUFFER_SIZE = 2;
QT_GL_LEVEL = 3;
QT_GL_RGBA = 4;
QT_GL_DOUBLEBUFFER = 5;
QT_GL_STEREO = 6;
QT_GL_AUX_BUFFERS = 7;
QT_GL_RED_SIZE = 8;
QT_GL_GREEN_SIZE = 9;
QT_GL_BLUE_SIZE = 10;
QT_GL_ALPHA_SIZE = 11;
QT_GL_DEPTH_SIZE = 12;
QT_GL_STENCIL_SIZE = 13;
QT_GL_ACCUM_RED_SIZE = 14;
QT_GL_ACCUM_GREEN_SIZE = 15;
QT_GL_ACCUM_BLUE_SIZE = 16;
QT_GL_ACCUM_ALPHA_SIZE = 17;
// GLX_EXT_visual_info extension
QT_GL_X_VISUAL_TYPE_EXT = $22;
QT_GL_TRANSPARENT_TYPE_EXT = $23;
QT_GL_TRANSPARENT_INDEX_VALUE_EXT = $24;
QT_GL_TRANSPARENT_RED_VALUE_EXT = $25;
QT_GL_TRANSPARENT_GREEN_VALUE_EXT = $26;
QT_GL_TRANSPARENT_BLUE_VALUE_EXT = $27;
QT_GL_TRANSPARENT_ALPHA_VALUE_EXT = $28;
type
TGLXContext = pointer;
procedure LOpenGLViewport(Left, Top, Width, Height: integer);
procedure LOpenGLSwapBuffers(Handle: HWND);
function LOpenGLMakeCurrent(Handle: HWND): boolean;
function LOpenGLCreateContext(AWinControl: TWinControl;
WSPrivate: TWSPrivateClass; SharedControl: TWinControl;
DoubleBuffered, RGBA: boolean;
const AParams: TCreateParams): HWND;
procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl);
function CreateOpenGLContextAttrList(DoubleBuffered: boolean;
RGBA: boolean): PInteger;
implementation
type
//PGLXPixmap = ^GLXPixmap;
GLXPixmap = TXID;
//PGLXDrawable = ^GLXDrawable;
GLXDrawable = TXID;
{ GLX 1.0 functions. }
function glXChooseVisual(dpy:PDisplay; screen:longint; attrib_list:Plongint):PXVisualInfo;cdecl;external;
procedure glXCopyContext(dpy:PDisplay; src:TGLXContext; dst:TGLXContext; mask: cardinal);cdecl;external;
function glXCreateContext(dpy:PDisplay; vis:PXVisualInfo; share_list:TGLXContext; direct:TBool):TGLXContext;cdecl;external;
function glXCreateGLXPixmap(dpy:PDisplay; vis:PXVisualInfo; pixmap:TPixmap):GLXPixmap;cdecl;external;
procedure glXDestroyContext(dpy:PDisplay; ctx:TGLXContext);cdecl;external;
procedure glXDestroyGLXPixmap(dpy:PDisplay; pix:GLXPixmap);cdecl;external;
function glXGetConfig(dpy:PDisplay; vis:PXVisualInfo; attrib:longint; value:Plongint):longint;cdecl;external;
function glXGetCurrentContext:TGLXContext;cdecl;external;
function glXGetCurrentDrawable:GLXDrawable;cdecl;external;
function glXIsDirect(dpy:PDisplay; ctx:TGLXContext):TBool;cdecl;external;
function glXMakeCurrent(dpy:PDisplay; drawable:GLXDrawable; ctx:TGLXContext):TBool;cdecl;external;
function glXQueryExtension(dpy:PDisplay; error_base:Plongint; event_base:Plongint):TBool;cdecl;external;
function glXQueryVersion(dpy:PDisplay; major:Plongint; minor:Plongint):TBool;cdecl;external;
procedure glXSwapBuffers(dpy:PDisplay; drawable:GLXDrawable);cdecl;external;
procedure glXUseXFont(font:TFont; first:longint; count:longint; list_base:longint);cdecl;external;
procedure glXWaitGL;cdecl;external;
procedure glXWaitX;cdecl;external;
function XVisualAsString(AVisual: PVisual): string;
begin
if AVisual=nil then begin
Result:='nil';
end else begin
Result:=''
+' bits_per_rgb='+dbgs(AVisual^.bits_per_rgb)
+' red_mask='+hexstr(AVisual^.red_mask,8)
+' green_mask='+hexstr(AVisual^.green_mask,8)
+' blue_mask='+hexstr(AVisual^.blue_mask,8)
+' map_entries='+dbgs(AVisual^.map_entries)
+'';
end;
end;
function XDisplayAsString(ADisplay: PDisplay): string;
begin
if ADisplay=nil then begin
Result:='nil';
end else begin
Result:=''
+'';
end;
end;
type
{ TQtGLWidget }
TQtGLWidget = class(TQtWidget)
public
xdisplay: PDisplay;
visual: PXVisualInfo;
glxcontext: TGLXContext;
ref_count: integer;
function GetGLXDrawable: GLXDrawable;
end;
{ TQtGLWidget }
function TQtGLWidget.GetGLXDrawable: GLXDrawable;
begin
Result:=0; {$ERROR ToDo: get GLXDrawable}
end;
procedure LOpenGLViewport(Left, Top, Width, Height: integer);
begin
glViewport(Left,Top,Width,Height);
end;
procedure LOpenGLSwapBuffers(Handle: HWND);
var
Widget: TQtGLWidget;
begin
if Handle=0 then
RaiseGDBException('LOpenGLSwapBuffers Handle=0');
Widget:=TQtGLWidget(Handle);
glXSwapBuffers(Widget.xdisplay,
Widget.GetGLXDrawable
);
end;
function LOpenGLMakeCurrent(Handle: HWND): boolean;
var
Widget: TQtGLWidget;
begin
if Handle=0 then
RaiseGDBException('LOpenGLSwapBuffers Handle=0');
Result:=false;
Widget:=TQtGLWidget(Handle);
Result:=boolean(glXMakeCurrent(Widget.xdisplay,
Widget.GetGLXDrawable,
Widget.glxcontext));
end;
function LOpenGLCreateContext(AWinControl: TWinControl;
WSPrivate: TWSPrivateClass; SharedControl: TWinControl; DoubleBuffered,
RGBA: boolean; const AParams: TCreateParams): HWND;
var
AttrList: PInteger;
NewQtWidget: TQtGLWidget;
direct: TBool;
begin
if WSPrivate=nil then ;
AttrList:=CreateOpenGLContextAttrList(DoubleBuffered,RGBA);
try
NewQtWidget:=TQtGLWidget.Create(AWinControl,AParams);
NewQtWidget.xdisplay := QX11Info_display;
NewQtWidget.visual:=glXChooseVisual(NewQtWidget.xdisplay,
DefaultScreen(NewQtWidget.xdisplay), @attrList[0]);
direct:=0;
NewQtWidget.glxcontext := glXCreateContext(NewQtWidget.xdisplay,
NewQtWidget.visual, nil, direct);
NewQtWidget.ref_count := 1;
NewQtWidget.AttachEvents;
Result:=HWND(PtrUInt(Pointer(NewQtWidget)));
finally
FreeMem(AttrList);
end;
end;
procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl);
begin
if not AWinControl.HandleAllocated then exit;
// nothing to do
end;
function CreateOpenGLContextAttrList(DoubleBuffered: boolean; RGBA: boolean
): PInteger;
var
p: integer;
procedure Add(i: integer);
begin
if Result<>nil then
Result[p]:=i;
inc(p);
end;
procedure CreateList;
begin
if DoubleBuffered then
Add(QT_GL_DOUBLEBUFFER);
if RGBA then
Add(QT_GL_RGBA);
Add(QT_GL_RED_SIZE); Add(1);
Add(QT_GL_GREEN_SIZE); Add(1);
Add(QT_GL_BLUE_SIZE); Add(1);
Add(QT_GL_DEPTH_SIZE); Add(1);
Add(QT_GL_STENCIL_SIZE); Add(1);
Add(QT_GL_None);
end;
begin
Result:=nil;
p:=0;
CreateList;
GetMem(Result,SizeOf(integer)*p);
p:=0;
CreateList;
end;
end.
vendor/kam_remake/src/ext/LazarusOpenGL/glwin32wglcontext.pas
Vendored
+462
View File
@@ -0,0 +1,462 @@
{
*****************************************************************************
* *
* See the file COPYING.modifiedLGPL.txt, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
Author: Mattias Gaertner
}
unit GLWin32WGLContext;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LMessages, Windows, LCLProc, LCLType, gl, Forms, Controls,
Win32Int, WSLCLClasses, WSControls, Win32WSControls, Win32Proc, LCLMessageGlue;
procedure LOpenGLViewport(Left, Top, Width, Height: integer);
procedure LOpenGLSwapBuffers(Handle: HWND);
function LOpenGLMakeCurrent(Handle: HWND): boolean;
function LOpenGLCreateContext(AWinControl: TWinControl;
WSPrivate: TWSPrivateClass; SharedControl: TWinControl;
DoubleBuffered, RGBA: boolean;
const AParams: TCreateParams): HWND;
procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl);
procedure InitWGL;
procedure InitOpenGLContextGLWindowClass;
type
TWGLControlInfo = record
Window: HWND;
DC: HDC;
PixelFormat: GLUInt;
WGLContext: HGLRC;
end;
PWGLControlInfo = ^TWGLControlInfo;
var
WGLControlInfoAtom: ATOM = 0;
function AllocWGLControlInfo(Window: HWND): PWGLControlInfo;
function DisposeWGLControlInfo(Window: HWND): boolean;
function GetWGLControlInfo(Window: HWND): PWGLControlInfo;
const
WGL_SAMPLE_BUFFERS_ARB = $2041;
WGL_SAMPLES_ARB = $2042;
// WGL_ARB_pixel_format
WGL_NUMBER_PIXEL_FORMATS_ARB = $2000;
WGL_DRAW_TO_WINDOW_ARB = $2001;
WGL_DRAW_TO_BITMAP_ARB = $2002;
WGL_ACCELERATION_ARB = $2003;
WGL_NEED_PALETTE_ARB = $2004;
WGL_NEED_SYSTEM_PALETTE_ARB = $2005;
WGL_SWAP_LAYER_BUFFERS_ARB = $2006;
WGL_SWAP_METHOD_ARB = $2007;
WGL_NUMBER_OVERLAYS_ARB = $2008;
WGL_NUMBER_UNDERLAYS_ARB = $2009;
WGL_TRANSPARENT_ARB = $200A;
WGL_TRANSPARENT_RED_VALUE_ARB = $2037;
WGL_TRANSPARENT_GREEN_VALUE_ARB = $2038;
WGL_TRANSPARENT_BLUE_VALUE_ARB = $2039;
WGL_TRANSPARENT_ALPHA_VALUE_ARB = $203A;
WGL_TRANSPARENT_INDEX_VALUE_ARB = $203B;
WGL_SHARE_DEPTH_ARB = $200C;
WGL_SHARE_STENCIL_ARB = $200D;
WGL_SHARE_ACCUM_ARB = $200E;
WGL_SUPPORT_GDI_ARB = $200F;
WGL_SUPPORT_OPENGL_ARB = $2010;
WGL_DOUBLE_BUFFER_ARB = $2011;
WGL_STEREO_ARB = $2012;
WGL_PIXEL_TYPE_ARB = $2013;
WGL_COLOR_BITS_ARB = $2014;
WGL_RED_BITS_ARB = $2015;
WGL_RED_SHIFT_ARB = $2016;
WGL_GREEN_BITS_ARB = $2017;
WGL_GREEN_SHIFT_ARB = $2018;
WGL_BLUE_BITS_ARB = $2019;
WGL_BLUE_SHIFT_ARB = $201A;
WGL_ALPHA_BITS_ARB = $201B;
WGL_ALPHA_SHIFT_ARB = $201C;
WGL_ACCUM_BITS_ARB = $201D;
WGL_ACCUM_RED_BITS_ARB = $201E;
WGL_ACCUM_GREEN_BITS_ARB = $201F;
WGL_ACCUM_BLUE_BITS_ARB = $2020;
WGL_ACCUM_ALPHA_BITS_ARB = $2021;
WGL_DEPTH_BITS_ARB = $2022;
WGL_STENCIL_BITS_ARB = $2023;
WGL_AUX_BUFFERS_ARB = $2024;
WGL_NO_ACCELERATION_ARB = $2025;
WGL_GENERIC_ACCELERATION_ARB = $2026;
WGL_FULL_ACCELERATION_ARB = $2027;
WGL_SWAP_EXCHANGE_ARB = $2028;
WGL_SWAP_COPY_ARB = $2029;
WGL_SWAP_UNDEFINED_ARB = $202A;
WGL_TYPE_RGBA_ARB = $202B;
WGL_TYPE_COLORINDEX_ARB = $202C;
// WGL_NV_float_buffer
WGL_FLOAT_COMPONENTS_NV = $20B0;
WGL_BIND_TO_TEXTURE_RECTANGLE_FLOAT_R_NV = $20B1;
WGL_BIND_TO_TEXTURE_RECTANGLE_FLOAT_RG_NV = $20B2;
WGL_BIND_TO_TEXTURE_RECTANGLE_FLOAT_RGB_NV = $20B3;
WGL_BIND_TO_TEXTURE_RECTANGLE_FLOAT_RGBA_NV = $20B4;
WGL_TEXTURE_FLOAT_R_NV = $20B5;
WGL_TEXTURE_FLOAT_RG_NV = $20B6;
WGL_TEXTURE_FLOAT_RGB_NV = $20B7;
WGL_TEXTURE_FLOAT_RGBA_NV = $20B8;
// WGL_ARB_pbuffer
type
HPBUFFERARB = Integer;
TGLenum = uint;
const
WGL_DRAW_TO_PBUFFER_ARB = $202D;
WGL_MAX_PBUFFER_PIXELS_ARB = $202E;
WGL_MAX_PBUFFER_WIDTH_ARB = $202F;
WGL_MAX_PBUFFER_HEIGHT_ARB = $2030;
WGL_PBUFFER_LARGEST_ARB = $2033;
WGL_PBUFFER_WIDTH_ARB = $2034;
WGL_PBUFFER_HEIGHT_ARB = $2035;
WGL_PBUFFER_LOST_ARB = $2036;
// WGL_ARB_buffer_region
WGL_FRONT_COLOR_BUFFER_BIT_ARB = $00000001;
WGL_BACK_COLOR_BUFFER_BIT_ARB = $00000002;
WGL_DEPTH_BUFFER_BIT_ARB = $00000004;
WGL_STENCIL_BUFFER_BIT_ARB = $00000008;
const
opengl32 = 'OpenGL32.dll';
glu32 = 'GLU32.dll';
type
PWGLSwap = ^TWGLSwap;
_WGLSWAP = packed record
hdc: HDC;
uiFlags: UINT;
end;
TWGLSwap = _WGLSWAP;
WGLSWAP = _WGLSWAP;
function wglGetProcAddress(ProcName: PChar): Pointer; stdcall; external opengl32;
function wglCopyContext(p1: HGLRC; p2: HGLRC; p3: Cardinal): BOOL; stdcall; external opengl32;
function wglCreateContext(DC: HDC): HGLRC; stdcall; external opengl32;
function wglCreateLayerContext(p1: HDC; p2: Integer): HGLRC; stdcall; external opengl32;
function wglDeleteContext(p1: HGLRC): BOOL; stdcall; external opengl32;
function wglDescribeLayerPlane(p1: HDC; p2, p3: Integer; p4: Cardinal; var p5: TLayerPlaneDescriptor): BOOL; stdcall; external opengl32;
function wglGetCurrentContext: HGLRC; stdcall; external opengl32;
function wglGetCurrentDC: HDC; stdcall; external opengl32;
function wglGetLayerPaletteEntries(p1: HDC; p2, p3, p4: Integer; var pcr): Integer; stdcall; external opengl32;
function wglMakeCurrent(DC: HDC; p2: HGLRC): BOOL; stdcall; external opengl32;
function wglRealizeLayerPalette(p1: HDC; p2: Integer; p3: BOOL): BOOL; stdcall; external opengl32;
function wglSetLayerPaletteEntries(p1: HDC; p2, p3, p4: Integer; var pcr): Integer; stdcall; external opengl32;
function wglShareLists(p1, p2: HGLRC): BOOL; stdcall; external opengl32;
function wglSwapLayerBuffers(p1: HDC; p2: Cardinal): BOOL; stdcall; external opengl32;
function wglUseFontBitmapsA(DC: HDC; p2, p3, p4: DWORD): BOOL; stdcall; external opengl32;
function wglUseFontOutlinesA (p1: HDC; p2, p3, p4: DWORD; p5, p6: Single; p7: Integer; p8: PGlyphMetricsFloat): BOOL; stdcall; external opengl32;
function wglUseFontBitmapsW(DC: HDC; p2, p3, p4: DWORD): BOOL; stdcall; external opengl32;
function wglUseFontOutlinesW (p1: HDC; p2, p3, p4: DWORD; p5, p6: Single; p7: Integer; p8: PGlyphMetricsFloat): BOOL; stdcall; external opengl32;
function wglUseFontBitmaps(DC: HDC; p2, p3, p4: DWORD): BOOL; stdcall; external opengl32 name 'wglUseFontBitmapsA';
function wglUseFontOutlines(p1: HDC; p2, p3, p4: DWORD; p5, p6: Single; p7: Integer; p8: PGlyphMetricsFloat): BOOL; stdcall; external opengl32 name 'wglUseFontOutlinesA';
var
// WGL Extensions ----------------------------
WGL_EXT_swap_control: boolean;
WGL_ARB_multisample: boolean;
WGL_ARB_extensions_string: boolean;
WGL_ARB_pixel_format: boolean;
WGL_ARB_pbuffer: boolean;
WGL_ARB_buffer_region: boolean;
WGL_ATI_pixel_format_float: boolean;
// ARB wgl extensions
wglGetExtensionsStringARB: function(DC: HDC): PChar; stdcall;
wglGetPixelFormatAttribivARB: function(DC: HDC; iPixelFormat, iLayerPlane: Integer; nAttributes: TGLenum;
const piAttributes: PGLint; piValues : PGLint) : BOOL; stdcall;
wglGetPixelFormatAttribfvARB: function(DC: HDC; iPixelFormat, iLayerPlane: Integer; nAttributes: TGLenum;
const piAttributes: PGLint; piValues: PGLFloat) : BOOL; stdcall;
wglChoosePixelFormatARB: function(DC: HDC; const piAttribIList: PGLint; const pfAttribFList: PGLFloat;
nMaxFormats: GLint; piFormats: PGLint; nNumFormats: PGLenum) : BOOL; stdcall;
wglCreatePbufferARB: function(DC: HDC; iPixelFormat: Integer; iWidth, iHeight : Integer;
const piAttribList: PGLint) : HPBUFFERARB; stdcall;
wglGetPbufferDCARB: function(hPbuffer: HPBUFFERARB) : HDC; stdcall;
wglReleasePbufferDCARB: function(hPbuffer: HPBUFFERARB; DC: HDC) : Integer; stdcall;
wglDestroyPbufferARB: function(hPbuffer: HPBUFFERARB): BOOL; stdcall;
wglQueryPbufferARB: function(hPbuffer: HPBUFFERARB; iAttribute : Integer;
piValue: PGLint) : BOOL; stdcall;
wglCreateBufferRegionARB: function(DC: HDC; iLayerPlane: Integer; uType: TGLenum) : Integer; stdcall;
wglDeleteBufferRegionARB: procedure(hRegion: Integer); stdcall;
wglSaveBufferRegionARB: function(hRegion: Integer; x, y, width, height: Integer): BOOL; stdcall;
wglRestoreBufferRegionARB: function(hRegion: Integer; x, y, width, height: Integer;
xSrc, ySrc: Integer): BOOL; stdcall;
// non-ARB wgl extensions
wglSwapIntervalEXT: function(interval : Integer) : BOOL; stdcall;
wglGetSwapIntervalEXT: function : Integer; stdcall;
var
WGLInitialized: boolean = false;
OpenGLContextWindowClassInitialized: boolean = false;
OpenGLContextWindowClass: WNDCLASS;
const
DefaultOpenGLContextInitAttrList: array [0..0] of LongInt = (
0
);
implementation
function GLGetProcAddress(ProcName: PChar):Pointer;
begin
Result := wglGetProcAddress(ProcName);
end;
procedure LOpenGLViewport(Left, Top, Width, Height: integer);
begin
glViewport(Left,Top,Width,Height);
end;
procedure LOpenGLSwapBuffers(Handle: HWND);
var
Info: PWGLControlInfo;
begin
Info:=GetWGLControlInfo(Handle);
// don't use wglSwapLayerBuffers or wglSwapBuffers!
SwapBuffers(Info^.DC);
end;
function LOpenGLMakeCurrent(Handle: HWND): boolean;
var
Info: PWGLControlInfo;
begin
Info:=GetWGLControlInfo(Handle);
Result:=wglMakeCurrent(Info^.DC,Info^.WGLContext);
end;
function GlWindowProc(Window: HWnd; Msg: UInt; WParam: Windows.WParam;
LParam: Windows.LParam): LResult; stdcall;
var
PaintMsg : TLMPaint;
winctrl : TWinControl;
begin
case Msg of
WM_ERASEBKGND: begin
Result:=0;
end;
WM_PAINT: begin
winctrl := GetWin32WindowInfo(Window)^.WinControl;
if Assigned(winctrl) then begin
FillChar(PaintMsg, SizeOf(PaintMsg), 0);
PaintMsg.Msg := LM_PAINT;
PaintMsg.DC := WParam;
DeliverMessage(winctrl, PaintMsg);
Result:=PaintMsg.Result;
end else
Result:=WindowProc(Window, Msg, WParam, LParam);
end;
else
Result:=WindowProc(Window, Msg, WParam, LParam);
end;
end;
function LOpenGLCreateContext(AWinControl: TWinControl;
WSPrivate: TWSPrivateClass; SharedControl: TWinControl;
DoubleBuffered, RGBA: boolean; const AParams: TCreateParams): HWND;
var
Params: TCreateWindowExParams;
pfd: PIXELFORMATDESCRIPTOR;
Info: PWGLControlInfo;
begin
InitWGL;
//InitOpenGLContextGLWindowClass;
// general initialization of Params
PrepareCreateWindow(AWinControl, AParams, Params);
// customization of Params
with Params do begin
pClassName := @ClsName;
WindowTitle := StrCaption;
SubClassWndProc := @GlWindowProc;
end;
// create window
FinishCreateWindow(AWinControl, Params, false);
Result := Params.Window;
// create info
Info:=AllocWGLControlInfo(Result);
// create device context
Info^.DC := GetDC(Result);
if Info^.DC=0 then
raise Exception.Create('LOpenGLCreateContext GetDC failed');
// get pixelformat
FillChar(pfd,SizeOf(pfd),0);
with pfd do begin
nSize:=sizeOf(pfd);
nVersion:=1;
dwFlags:=PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL;
if DoubleBuffered then
dwFlags:=dwFlags or PFD_DOUBLEBUFFER;
if RGBA then
iPixelType:=PFD_TYPE_RGBA
else
iPixelType:=PFD_TYPE_COLORINDEX;
cColorBits:=24; // color depth
cDepthBits:=16; // Z-Buffer
iLayerType:=PFD_MAIN_PLANE;
end;
Info^.PixelFormat:=ChoosePixelFormat(Info^.DC,@pfd);
if Info^.PixelFormat=0 then
raise Exception.Create('LOpenGLCreateContext ChoosePixelFormat failed');
// set pixel format in device context
if not SetPixelFormat(Info^.DC,Info^.PixelFormat,@pfd) then
raise Exception.Create('LOpenGLCreateContext SetPixelFormat failed');
// create WGL context
Info^.WGLContext:=wglCreateContext(Info^.DC);
if Info^.WGLContext=0 then
raise Exception.Create('LOpenGLCreateContext wglCreateContext failed');
end;
procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl);
var
Info: PWGLControlInfo;
begin
if not AWinControl.HandleAllocated then exit;
Info:=GetWGLControlInfo(AWinControl.Handle);
if Info=nil then exit;
if wglMakeCurrent(Info^.DC,Info^.WGLContext) then begin
wglDeleteContext(Info^.WGLContext);
Info^.WGLContext:=0;
end;
if (Info^.DC<>0) then begin
ReleaseDC(Info^.Window,Info^.DC);
end;
DisposeWGLControlInfo(Info^.Window);
end;
procedure InitWGL;
var
Buffer: string;
// Checks if the given Extension string is in Buffer.
function CheckExtension(const extension : String) : Boolean;
begin
Result:=(Pos(extension, Buffer)>0);
end;
begin
if WGLInitialized then exit;
WGLInitialized:=true;
try
// ARB wgl extensions
Pointer(wglGetExtensionsStringARB) := GLGetProcAddress('wglGetExtensionsStringARB');
Pointer(wglGetPixelFormatAttribivARB) := GLGetProcAddress('wglGetPixelFormatAttribivARB');
Pointer(wglGetPixelFormatAttribfvARB) := GLGetProcAddress('wglGetPixelFormatAttribfvARB');
Pointer(wglChoosePixelFormatARB) := GLGetProcAddress('wglChoosePixelFormatARB');
Pointer(wglCreatePbufferARB) := GLGetProcAddress('wglCreatePbufferARB');
Pointer(wglGetPbufferDCARB) := GLGetProcAddress('wglGetPbufferDCARB');
Pointer(wglReleasePbufferDCARB) := GLGetProcAddress('wglReleasePbufferDCARB');
Pointer(wglDestroyPbufferARB) := GLGetProcAddress('wglDestroyPbufferARB');
Pointer(wglQueryPbufferARB) := GLGetProcAddress('wglQueryPbufferARB');
Pointer(wglCreateBufferRegionARB) := GLGetProcAddress('wglCreateBufferRegionARB');
Pointer(wglDeleteBufferRegionARB) := GLGetProcAddress('wglDeleteBufferRegionARB');
Pointer(wglSaveBufferRegionARB) := GLGetProcAddress('wglSaveBufferRegionARB');
Pointer(wglRestoreBufferRegionARB) := GLGetProcAddress('wglRestoreBufferRegionARB');
// -EGG- ----------------------------
Pointer(wglSwapIntervalEXT) := GLGetProcAddress('wglSwapIntervalEXT');
Pointer(wglGetSwapIntervalEXT) := GLGetProcAddress('wglGetSwapIntervalEXT');
// ARB wgl extensions
if Assigned(wglGetExtensionsStringARB) then
Buffer:=wglGetExtensionsStringARB(wglGetCurrentDC)
else
Buffer:='';
WGL_ARB_multisample:=CheckExtension('WGL_ARB_multisample');
WGL_EXT_swap_control:=CheckExtension('WGL_EXT_swap_control');
WGL_ARB_buffer_region:=CheckExtension('WGL_ARB_buffer_region');
WGL_ARB_extensions_string:=CheckExtension('WGL_ARB_extensions_string');
WGL_ARB_pbuffer:=CheckExtension('WGL_ARB_pbuffer ');
WGL_ARB_pixel_format:=CheckExtension('WGL_ARB_pixel_format');
WGL_ATI_pixel_format_float:=CheckExtension('WGL_ATI_pixel_format_float');
except
on E: Exception do begin
DebugLn('InitWGL ',E.Message);
end;
end;
end;
procedure InitOpenGLContextGLWindowClass;
begin
if OpenGLContextWindowClassInitialized then exit;
OpenGLContextWindowClassInitialized:=true;
with OpenGLContextWindowClass do begin
style:=CS_HREDRAW or CS_VREDRAW or CS_OWNDC;// Redraw On Move, And Own DC For Window
lpfnWndProc := @WindowProc; // WndProc Handles Messages
cbClsExtra := 0; // No Extra Window Data
cbWndExtra := 0; // No Extra Window Data
hInstance := System.HInstance; // Set The Instance
hIcon := LoadIcon(NULL, IDI_WINLOGO);// Load The Default Icon
hCursor := LoadCursor(NULL, IDC_ARROW);// Load The Arrow Pointer
hbrBackground:= NULL; // No Background Required For GL
lpszMenuName := nil; // We Don't Want A Menu
lpszClassName:= 'LazOpenGLContext'; // Set The Class Name
end;
if RegisterClass(@OpenGLContextWindowClass)=0 then
raise Exception.Create('registering OpenGLContextWindowClass failed');
end;
function AllocWGLControlInfo(Window: HWND): PWGLControlInfo;
begin
New(Result);
FillChar(Result^, sizeof(Result^), 0);
Result^.Window := Window;
if WGLControlInfoAtom=0 then
WGLControlInfoAtom := Windows.GlobalAddAtom('WGLControlInfo');
Windows.SetProp(Window, PChar(PtrUInt(WGLControlInfoAtom)), PtrUInt(Result));
end;
function DisposeWGLControlInfo(Window: HWND): boolean;
var
Info: PWGLControlInfo;
begin
Info := PWGLControlInfo(Windows.GetProp(Window,
PChar(PtrUInt(WGLControlInfoAtom))));
Result := Windows.RemoveProp(Window, PChar(PtrUInt(WGLControlInfoAtom)))<>0;
if Result then begin
Dispose(Info);
end;
end;
function GetWGLControlInfo(Window: HWND): PWGLControlInfo;
begin
Result:=PWGLControlInfo(Windows.GetProp(Window,
PChar(PtrUInt(WGLControlInfoAtom))));
end;
end.
vendor/kam_remake/src/ext/LazarusOpenGL/openglcontext.pas
Vendored
+487
View File
@@ -0,0 +1,487 @@
{
*****************************************************************************
* *
* See the file COPYING.modifiedLGPL.txt, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
Author: Mattias Gaertner
Abstract:
TOpenGLControl is a LCL control with an opengl context.
It works under the following platforms:
- gtk with glx : full
- gtk2 with glx : full
- carbon with agl : full
- cocoa : no
- windows with wgl: full
- wince : no
- qt with glx : no (started)
- fpgui with glx : no
- nogui : no
}
unit OpenGLContext;
{$mode objfpc}{$H+}
// choose the right backend depending on used LCL widgetset
{$IFDEF LCLGTK}
{$IFDEF Linux}
{$DEFINE UseGtkGLX}
{$DEFINE OpenGLTargetDefined}
{$ENDIF}
{$ENDIF}
{$IFDEF LCLGTK2}
{$IFDEF Linux}
{$DEFINE UseGtk2GLX}
{$DEFINE OpenGLTargetDefined}
{$ENDIF}
{$ENDIF}
{$IFDEF LCLCarbon}
{$DEFINE UseCarbonAGL}
{$DEFINE OpenGLTargetDefined}
{$ENDIF}
{$IFDEF LCLWin32}
{$DEFINE UseWin32WGL}
{$DEFINE OpenGLTargetDefined}
{$ENDIF}
{$IFDEF LCLQT}
{$DEFINE UseQTGLX}
{$DEFINE OpenGLTargetDefined}
{$ENDIF}
{$IFNDEF OpenGLTargetDefined}
{$ERROR this LCL widgetset/OS is not yet supported}
{$ENDIF}
interface
uses
Classes, SysUtils, LCLProc, Forms, Controls, LCLType, LCLIntf, LResources,
Graphics, LMessages, WSLCLClasses, WSControls,
{$IFDEF UseGtkGLX}
GLGtkGlxContext;
{$ENDIF}
{$IFDEF UseGtk2GLX}
GLGtkGlxContext;
{$ENDIF}
{$IFDEF UseCarbonAGL}
GLCarbonAGLContext;
{$ENDIF}
{$IFDEF UseWin32WGL}
GLWin32WGLContext;
{$ENDIF}
{$IFDEF UseQTGLX}
GLQTContext;
{$ENDIF}
type
TOpenGlCtrlMakeCurrentEvent = procedure(Sender: TObject;
var Allow: boolean) of object;
{ TCustomOpenGLControl }
{ Sharing:
You can share opengl contexts. For example:
Assume OpenGLControl2 and OpenGLControl3 should share the same as
OpenGLControl1. Then set
OpenGLControl2.SharedControl:=OpenGLControl1;
OpenGLControl3.SharedControl:=OpenGLControl1;
After this OpenGLControl1.SharingControlCount will be two and
OpenGLControl1.SharingControls will contain OpenGLControl2 and
OpenGLControl3.
}
TCustomOpenGLControl = class(TWinControl)
private
FAutoResizeViewport: boolean;
FCanvas: TCanvas; // only valid at designtime
FDoubleBuffered: boolean;
FFrameDiffTime: integer;
FOnMakeCurrent: TOpenGlCtrlMakeCurrentEvent;
FOnPaint: TNotifyEvent;
FCurrentFrameTime: integer; // in msec
FLastFrameTime: integer; // in msec
FRGBA: boolean;
FSharedOpenGLControl: TCustomOpenGLControl;
FSharingOpenGlControls: TList;
function GetSharingControls(Index: integer): TCustomOpenGLControl;
procedure SetAutoResizeViewport(const AValue: boolean);
procedure SetDoubleBuffered(const AValue: boolean);
procedure SetRGBA(const AValue: boolean);
procedure SetSharedControl(const AValue: TCustomOpenGLControl);
protected
procedure WMPaint(var Message: TLMPaint); message LM_PAINT;
procedure WMSize(var Message: TLMSize); message LM_SIZE;
procedure UpdateFrameTimeDiff;
procedure OpenGLAttributesChanged;
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
Procedure Paint; virtual;
procedure RealizeBounds; override;
procedure DoOnPaint; virtual;
procedure SwapBuffers; virtual;
function MakeCurrent(SaveOldToStack: boolean = false): boolean; virtual;
function RestoreOldOpenGLControl: boolean;
function SharingControlCount: integer;
property SharingControls[Index: integer]: TCustomOpenGLControl read GetSharingControls;
procedure Invalidate; override;
procedure EraseBackground(DC: HDC); override;
public
property FrameDiffTimeInMSecs: integer read FFrameDiffTime;
property OnMakeCurrent: TOpenGlCtrlMakeCurrentEvent read FOnMakeCurrent
write FOnMakeCurrent;
property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
property SharedControl: TCustomOpenGLControl read FSharedOpenGLControl
write SetSharedControl;
property AutoResizeViewport: boolean read FAutoResizeViewport
write SetAutoResizeViewport default false;
property DoubleBuffered: boolean read FDoubleBuffered write SetDoubleBuffered default true;
property RGBA: boolean read FRGBA write SetRGBA default true;
end;
{ TOpenGLControl }
TOpenGLControl = class(TCustomOpenGLControl)
published
property Align;
property Anchors;
property AutoResizeViewport;
property BorderSpacing;
property Enabled;
property OnChangeBounds;
property OnClick;
property OnConstrainedResize;
property OnDblClick;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMakeCurrent;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnPaint;
property OnResize;
property OnShowHint;
property PopupMenu;
property ShowHint;
property Visible;
end;
{ TWSOpenGLControl }
TWSOpenGLControl = class(TWSWinControl)
published
class function CreateHandle(const AWinControl: TWinControl;
const AParams: TCreateParams): HWND; override;
class procedure DestroyHandle(const AWinControl: TWinControl); override;
end;
procedure Register;
implementation
var
OpenGLControlStack: TList = nil;
procedure Register;
begin
RegisterComponents('OpenGL',[TOpenGLControl]);
end;
{ TCustomOpenGLControl }
function TCustomOpenGLControl.GetSharingControls(Index: integer
): TCustomOpenGLControl;
begin
Result:=TCustomOpenGLControl(FSharingOpenGlControls[Index]);
end;
procedure TCustomOpenGLControl.SetAutoResizeViewport(const AValue: boolean);
begin
if FAutoResizeViewport=AValue then exit;
FAutoResizeViewport:=AValue;
if AutoResizeViewport
and ([csLoading,csDestroying]*ComponentState=[])
and IsVisible and HandleAllocated
and MakeCurrent then
LOpenGLViewport(0,0,Width,Height);
end;
procedure TCustomOpenGLControl.SetDoubleBuffered(const AValue: boolean);
begin
if FDoubleBuffered=AValue then exit;
FDoubleBuffered:=AValue;
OpenGLAttributesChanged;
end;
procedure TCustomOpenGLControl.SetRGBA(const AValue: boolean);
begin
if FRGBA=AValue then exit;
FRGBA:=AValue;
OpenGLAttributesChanged;
end;
procedure TCustomOpenGLControl.SetSharedControl(
const AValue: TCustomOpenGLControl);
begin
if FSharedOpenGLControl=AValue then exit;
if AValue=Self then
Raise Exception.Create('A control can not be shared by itself.');
// unshare old
if (AValue<>nil) and (AValue.SharedControl<>nil) then
Raise Exception.Create('Target control is sharing too. A sharing control can not be shared.');
if FSharedOpenGLControl<>nil then
FSharedOpenGLControl.FSharingOpenGlControls.Remove(Self);
// share new
if (AValue<>nil) and (csDestroying in AValue.ComponentState) then
FSharedOpenGLControl:=nil
else begin
FSharedOpenGLControl:=AValue;
if (FSharedOpenGLControl<>nil) then begin
if FSharedOpenGLControl.FSharingOpenGlControls=nil then
FSharedOpenGLControl.FSharingOpenGlControls:=TList.Create;
FSharedOpenGLControl.FSharingOpenGlControls.Add(Self);
end;
end;
// recreate handle if needed
if HandleAllocated and (not (csDesigning in ComponentState)) then
ReCreateWnd(Self);
end;
procedure TCustomOpenGLControl.WMPaint(var Message: TLMPaint);
begin
Include(FControlState, csCustomPaint);
inherited WMPaint(Message);
//debugln('TCustomGTKGLAreaControl.WMPaint A ',dbgsName(Self),' ',dbgsName(FCanvas));
if (csDesigning in ComponentState) and (FCanvas<>nil) then begin
with FCanvas do begin
if Message.DC <> 0 then
Handle := Message.DC;
Brush.Color:=clLtGray;
Pen.Color:=clRed;
Rectangle(0,0,Self.Width,Self.Height);
MoveTo(0,0);
LineTo(Self.Width,Self.Height);
MoveTo(0,Self.Height);
LineTo(Self.Width,0);
if Message.DC <> 0 then
Handle := 0;
end;
end else begin
Paint;
end;
Exclude(FControlState, csCustomPaint);
end;
procedure TCustomOpenGLControl.WMSize(var Message: TLMSize);
begin
if (Message.SizeType and Size_SourceIsInterface)>0 then
DoOnResize;
end;
procedure TCustomOpenGLControl.UpdateFrameTimeDiff;
begin
FCurrentFrameTime:=integer(GetTickCount);
if FLastFrameTime=0 then
FLastFrameTime:=FCurrentFrameTime;
// calculate time since last call:
FFrameDiffTime:=FCurrentFrameTime-FLastFrameTime;
// if the counter is reset restart:
if (FFrameDiffTime<0) then FFrameDiffTime:=1;
FLastFrameTime:=FCurrentFrameTime;
end;
procedure TCustomOpenGLControl.OpenGLAttributesChanged;
begin
if HandleAllocated
and ([csLoading,csDesigning,csDestroying]*ComponentState=[]) then
RecreateWnd(Self);
end;
procedure TCustomOpenGLControl.EraseBackground(DC: HDC);
begin
if DC=0 then ;
// everything is painted, so erasing the background is not needed
end;
constructor TCustomOpenGLControl.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
FDoubleBuffered:=true;
FRGBA:=true;
ControlStyle:=ControlStyle-[csSetCaption];
if (csDesigning in ComponentState) then begin
FCanvas := TControlCanvas.Create;
TControlCanvas(FCanvas).Control := Self;
end else
FCompStyle:=csNonLCL;
SetInitialBounds(0, 0, 160, 90);
end;
destructor TCustomOpenGLControl.Destroy;
begin
if FSharingOpenGlControls<>nil then begin
while SharingControlCount>0 do
SharingControls[SharingControlCount-1].SharedControl:=nil;
FreeAndNil(FSharingOpenGlControls);
end;
SharedControl:=nil;
if OpenGLControlStack<>nil then begin
OpenGLControlStack.Remove(Self);
if OpenGLControlStack.Count=0 then
FreeAndNil(OpenGLControlStack);
end;
FCanvas.Free;
FCanvas:=nil;
inherited Destroy;
end;
procedure TCustomOpenGLControl.Paint;
begin
if IsVisible and HandleAllocated then begin
UpdateFrameTimeDiff;
if ([csDesigning,csDestroying]*ComponentState=[]) then begin
if not MakeCurrent then exit;
if AutoResizeViewport then
LOpenGLViewport(0,0,Width,Height);
end;
//LOpenGLClip(Handle);
DoOnPaint;
end;
end;
procedure TCustomOpenGLControl.RealizeBounds;
begin
if IsVisible and HandleAllocated
and ([csDesigning,csDestroying]*ComponentState=[])
and AutoResizeViewport then begin
if MakeCurrent then
LOpenGLViewport(0,0,Width,Height);
end;
inherited RealizeBounds;
end;
procedure TCustomOpenGLControl.DoOnPaint;
begin
if Assigned(OnPaint) then OnPaint(Self);
end;
procedure TCustomOpenGLControl.SwapBuffers;
begin
LOpenGLSwapBuffers(Handle);
end;
function TCustomOpenGLControl.MakeCurrent(SaveOldToStack: boolean): boolean;
var
Allowed: Boolean;
begin
if csDesigning in ComponentState then exit(false);
if Assigned(FOnMakeCurrent) then begin
Allowed:=true;
OnMakeCurrent(Self,Allowed);
if not Allowed then begin
Result:=False;
exit;
end;
end;
// make current
Result:=LOpenGLMakeCurrent(Handle);
if Result and SaveOldToStack then begin
// on success push on stack
if OpenGLControlStack=nil then
OpenGLControlStack:=TList.Create;
OpenGLControlStack.Add(Self);
end;
end;
function TCustomOpenGLControl.RestoreOldOpenGLControl: boolean;
var
RestoredControl: TCustomOpenGLControl;
begin
Result:=false;
// check if the current context is on stack
if (OpenGLControlStack=nil) or (OpenGLControlStack.Count=0) then exit;
// pop
OpenGLControlStack.Delete(OpenGLControlStack.Count-1);
// make old control the current control
if OpenGLControlStack.Count>0 then begin
RestoredControl:=
TCustomOpenGLControl(OpenGLControlStack[OpenGLControlStack.Count-1]);
if (not LOpenGLMakeCurrent(RestoredControl.Handle)) then
exit;
end else begin
FreeAndNil(OpenGLControlStack);
end;
Result:=true;
end;
function TCustomOpenGLControl.SharingControlCount: integer;
begin
if FSharingOpenGlControls=nil then
Result:=0
else
Result:=FSharingOpenGlControls.Count;
end;
procedure TCustomOpenGLControl.Invalidate;
begin
if csCustomPaint in FControlState then exit;
inherited Invalidate;
end;
{ TWSOpenGLControl }
class function TWSOpenGLControl.CreateHandle(const AWinControl: TWinControl;
const AParams: TCreateParams): HWND;
var
OpenGlControl: TCustomOpenGLControl;
AttrControl: TCustomOpenGLControl;
begin
if csDesigning in AWinControl.ComponentState then begin
// do not use "inherited CreateHandle", because the LCL changes the hierarchy at run time
Result:=TWSWinControlClass(ClassParent).CreateHandle(AWinControl,AParams);
end
else begin
OpenGlControl:=AWinControl as TCustomOpenGLControl;
if OpenGlControl.SharedControl<>nil then
AttrControl:=OpenGlControl.SharedControl
else
AttrControl:=OpenGlControl;
Result:=LOpenGLCreateContext(OpenGlControl,WSPrivate,
OpenGlControl.SharedControl,
AttrControl.DoubleBuffered,AttrControl.RGBA,
AParams);
end;
end;
class procedure TWSOpenGLControl.DestroyHandle(const AWinControl: TWinControl);
begin
LOpenGLDestroyContextInfo(AWinControl);
// do not use "inherited DestroyHandle", because the LCL changes the hierarchy at run time
TWSWinControlClass(ClassParent).DestroyHandle(AWinControl);
end;
initialization
RegisterWSComponent(TCustomOpenGLControl,TWSOpenGLControl);
{.$I openglcontext.lrs}
end.