From 07d4b69c6a025b78e950a3360fec1a5ad5b57ff2 Mon Sep 17 00:00:00 2001 From: Bergmann89 Date: Sun, 21 Sep 2014 19:37:21 +0200 Subject: [PATCH] * added glcContext --- uglcContext.pas | 244 ++++++++++++++++++ uglcContextGtk2GLX.pas | 562 +++++++++++++++++++++++++++++++++++++++++ uglcContextGtkCustomVisual.pas | 225 +++++++++++++++++ uglcContextWGL.pas | 432 +++++++++++++++++++++++++++++++ 4 files changed, 1463 insertions(+) create mode 100644 uglcContext.pas create mode 100644 uglcContextGtk2GLX.pas create mode 100644 uglcContextGtkCustomVisual.pas create mode 100644 uglcContextWGL.pas diff --git a/uglcContext.pas b/uglcContext.pas new file mode 100644 index 0000000..ad00b99 --- /dev/null +++ b/uglcContext.pas @@ -0,0 +1,244 @@ +unit uglcContext; + +{ Package: OpenGLCore + Prefix: glc - OpenGL Core + Beschreibung: diese Unit enthält eine abstrakte Klassen-Kapselung für OpenGL Kontexte + + +Abstrakte Contextklasse zum Erstellen von Renderkontexten auf Windows & Linux(bzw X11/Gtk2) +Für aktuelle Plattform passende Klasse kann per GetPlatformClass gefunden werden. + +Bsp.: + //muss im GUI/Main-Thread aufgerufen werden: + pf := TglcContext.GetPlatformClass().MakePF(); + fContext := TglcContext.GetPlatformClass().Create(MyTWinControl, PF); + + //_kann_ in Background Thread abgerufen werden: + fContext.BuildContext(); + [Arbeit mit dem Context] + fContext.CloseContext(); + + //im MainThread + FreeAndNil(fContext) + + +weitere Funktionen: + MakePF() erzeugt PixelFormatDescriptor mit Defaults + BuildContext() baut Kontext (kann in BackgrounThread aufgerufen werden) + CloseContext() gibt den Kontext frei (muss im selben Thread aufgerufen werden wie BuildContext; + wird der Kontext nur im MainThread genutzt, muss CloseContext nicht explizit aufgerufen + werden und wird beim zerstören des Kontext-Objekts ausgeführt) + Activate/Deactiveate Kontext aktiv schalten oder nicht + SwapBuffers DoubleBuffering + SetSwapInterval VSync + Share ShareLists + EnableDebugOutput GL-Debug via ARB_debug_output oder AMD_debug_output de/aktivieren +} + +interface + +uses + SysUtils, Controls, dglOpenGL; + +const + GLC_CONTEXT_VERSION_UNKNOWN = -1; + +type + TMultiSample = 1..high(byte); + TglcContextPixelFormatSettings = packed record + DoubleBuffered: boolean; + Stereo: boolean; + MultiSampling: TMultiSample; + ColorBits: Integer; + DepthBits: Integer; + StencilBits: Integer; + AccumBits: Integer; + AuxBuffers: Integer; + Layer: Integer; + end; + TglcContextVersionSettings = packed record + Major: Integer; + Minor: Integer; + ForwardCompatible: Boolean; + end; + + TglcDisplayFlag = ( + dfFullscreen); + TglcDisplayFlags = set of TglcDisplayFlag; + + EGLError = class(Exception); + + { TglcContext } + TglcContextClass = class of TglcContext; + TglcContext = class + private + fControl: TWinControl; + fThreadID: TThreadID; + fEnableVsync: Boolean; + + function GetEnableVSync: Boolean; + procedure SetEnableVSync(aValue: Boolean); + + protected + fUseVersion: Boolean; + fPixelFormatSettings: TglcContextPixelFormatSettings; + fVersionSettings: TglcContextVersionSettings; + procedure OpenContext; virtual; + + public + property PixelFormatSettings: TglcContextPixelFormatSettings read fPixelFormatSettings; + property VersionSettings: TglcContextVersionSettings read fVersionSettings; + + constructor Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings); virtual; overload; + constructor Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings; const aVersionSettings: TglcContextVersionSettings); virtual; overload; + destructor Destroy; override; + + property ThreadID: TThreadID read fThreadID; + property EnableVSync: Boolean read GetEnableVSync write SetEnableVSync; + + procedure BuildContext; + procedure CloseContext; virtual; + procedure Activate; virtual; abstract; + procedure Deactivate; virtual; abstract; + function IsActive: boolean; virtual; abstract; + procedure SwapBuffers; virtual; abstract; + procedure SetSwapInterval(const aInterval: GLint); virtual; abstract; + function GetSwapInterval: GLint; virtual; abstract; + procedure Share(const aContext: TglcContext); virtual; abstract; + + private class var + fMainContextThreadID: TThreadID; + public + class property MainContextThreadID: TThreadID read fMainContextThreadID; + class function MakePF(DoubleBuffered: boolean = true; + Stereo: boolean=false; + MultiSampling: TMultiSample=1; + ColorBits: Integer=32; + DepthBits: Integer=24; + StencilBits: Integer=0; + AccumBits: Integer=0; + AuxBuffers: Integer=0; + Layer: Integer=0): TglcContextPixelFormatSettings; + class function MakeVersion(const aMajor, aMinor: Integer; const aForwardCompatible: Boolean): TglcContextVersionSettings; + class function GetPlatformClass: TglcContextClass; + class function ChangeDisplaySettings(const aWidth, aHeight, + aBitPerPixel, aFreq: Integer; const aFlags: TglcDisplayFlags): Boolean; virtual; abstract; + class function IsAnyContextActive: boolean; virtual; + end; + +implementation + +uses + {$IFDEF WINDOWS} + uglcContextWGL + {$ENDIF} + {$IFDEF LINUX} + uglcContextGtk2GLX + {$ENDIF} + ; + +function TglcContext.GetEnableVSync: Boolean; +begin + result := fEnableVsync; +end; + +procedure TglcContext.SetEnableVSync(aValue: Boolean); +begin + fEnableVsync := aValue; + if IsActive then begin + if fEnableVsync then + SetSwapInterval(1) + else + SetSwapInterval(0); + end; +end; + +procedure TglcContext.OpenContext; +begin + fThreadID := GetCurrentThreadId; + if fMainContextThreadID = 0 then + fMainContextThreadID := fThreadID; +end; + +class function TglcContext.MakePF(DoubleBuffered: boolean; Stereo: boolean; MultiSampling: TMultiSample; ColorBits: Integer; + DepthBits: Integer; StencilBits: Integer; AccumBits: Integer; AuxBuffers: Integer; Layer: Integer): TglcContextPixelFormatSettings; +begin + Result.DoubleBuffered:= DoubleBuffered; + Result.Stereo:= Stereo; + Result.MultiSampling:= MultiSampling; + Result.ColorBits:= ColorBits; + Result.DepthBits:= DepthBits; + Result.StencilBits:= StencilBits; + Result.AccumBits:= AccumBits; + Result.AuxBuffers:= AuxBuffers; + Result.Layer:= Layer; +end; + +class function TglcContext.MakeVersion(const aMajor, aMinor: Integer; const aForwardCompatible: Boolean): TglcContextVersionSettings; +begin + result.Major := aMajor; + result.Minor := aMinor; + result.ForwardCompatible := aForwardCompatible; +end; + +class function TglcContext.GetPlatformClass: TglcContextClass; +begin + {$IFDEF WINDOWS} + Result:= TglcContextWGL; + {$ENDIF} + {$IFDEF LINUX} + Result:= TglcContextGtk2GLX; + {$ENDIF} +end; + +class function TglcContext.IsAnyContextActive: boolean; +begin + Result:= GetPlatformClass.IsAnyContextActive; +end; + +constructor TglcContext.Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings); +begin + inherited Create; + fPixelFormatSettings := aPixelFormatSettings; + FControl := aControl; + fThreadID := 0; + fEnableVsync := false; + fUseVersion := false; + InitOpenGL(); +end; + +constructor TglcContext.Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings; const aVersionSettings: TglcContextVersionSettings); +begin + Create(aControl, aPixelFormatSettings); + fVersionSettings := aVersionSettings; + fUseVersion := true; +end; + +destructor TglcContext.Destroy; +begin + if (GetCurrentThreadId = fMainContextThreadID) then + fMainContextThreadID := 0; + CloseContext; + inherited Destroy; +end; + +procedure TglcContext.BuildContext; +begin + OpenContext; + Activate; + ReadImplementationProperties; + ReadExtensions; + SetEnableVSync(fEnableVsync); +end; + +procedure TglcContext.CloseContext; +begin + if fMainContextThreadID = fThreadID then + fMainContextThreadID := 0; +end; + +initialization + TglcContext.fMainContextThreadID := 0; + +end. + diff --git a/uglcContextGtk2GLX.pas b/uglcContextGtk2GLX.pas new file mode 100644 index 0000000..bbde99f --- /dev/null +++ b/uglcContextGtk2GLX.pas @@ -0,0 +1,562 @@ +unit uglcContextGtk2GLX; + +{ Package: OpenGLCore + Prefix: glc - OpenGL Core + Beschreibung: diese Unit enthält eine Klassen-Kapselung für OpenGL Kontexte für Linux + Hint: diese Unit sollte niemals direkt genutzt werden (siehe uglcContext) } + +interface + +uses + SysUtils, Controls, uglcContext, LCLType, XUtil, XLib, gdk2x, gtk2, gdk2, dglOpenGL, + LMessages, uglcContextGtkCustomVisual; + +type + EGLXError = class(EGLError); + + TRenderControl = class(TCustomVisualControl) + private + fTarget: TWinControl; + protected + procedure WndProc(var Message: TLMessage); override; + public + property Target: TWinControl read fTarget write fTarget; + end; + + { TglcContextGtk2GLX } + + TglcContextGtk2GLX = class(TglcContext) + private + FVisual: PXVisualInfo; + FDisplay: PDisplay; + FWidget: PGtkWidget; + FContext: GLXContext; + FRenderControl: TRenderControl; + procedure UpdateVisual(const aControl: TWinControl); + protected + procedure OpenContext; override; + public + constructor Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings); override; overload; + constructor Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings; const aVersionSettings: TglcContextVersionSettings); override; overload; + destructor Destroy; override; + + procedure CloseContext; override; + procedure Activate; override; + procedure Deactivate; override; + function IsActive: boolean; override; + procedure SwapBuffers; override; + procedure SetSwapInterval(const aInterval: GLint); override; + procedure Share(const aContext: TglcContext); override; + + class function ChangeDisplaySettings(const aWidth, aHeight, + aBitPerPixel, aFreq: Integer; const aFlags: TglcDisplayFlags): Boolean; override; + class function IsAnyContextActive: boolean; override; + end; + +implementation + +type + TGLIntArray = packed array of GLInt; + +{$region messages -fold} +procedure TRenderControl.WndProc(var Message: TLMessage); +var + handled: Boolean; +begin + handled := false; + case Message.msg of + //LM_ACTIVATEITEM, + //LM_CHANGED, + //LM_FOCUS, + LM_CLICKED, + //LM_RELEASED, + LM_ENTER, + LM_LEAVE, + //LM_CHECKRESIZE, + //LM_SETEDITABLE, + //LM_MOVEWORD, + //LM_MOVEPAGE, + //LM_MOVETOROW, + //LM_MOVETOCOLUMN, + //LM_KILLCHAR, + //LM_KILLWORD, + //LM_KILLLINE, + //LM_CLOSEQUERY, + //LM_DRAGSTART, + //LM_MONTHCHANGED, + //LM_YEARCHANGED, + //LM_DAYCHANGED, + LM_LBUTTONTRIPLECLK, + LM_LBUTTONQUADCLK, + LM_MBUTTONTRIPLECLK, + LM_MBUTTONQUADCLK, + LM_RBUTTONTRIPLECLK, + LM_RBUTTONQUADCLK, + LM_MOUSEENTER, + LM_MOUSELEAVE, + LM_XBUTTONTRIPLECLK, + LM_XBUTTONQUADCLK, + + //SC_SIZE, + //SC_MOVE, + //SC_MINIMIZE, + //SC_MAXIMIZE, + //SC_NEXTWINDOW, + //SC_PREVWINDOW, + //SC_CLOSE, + SC_VSCROLL, + SC_HSCROLL, + SC_MOUSEMENU, + SC_KEYMENU, + //SC_ARRANGE, + //SC_RESTORE, + //SC_TASKLIST, + //SC_SCREENSAVE, + //SC_HOTKEY, + //SC_DEFAULT, + //SC_MONITORPOWER, + //SC_CONTEXTHELP, + //SC_SEPARATOR, + + //LM_MOVE, + //LM_SIZE, + LM_ACTIVATE, + LM_SETFOCUS, + LM_KILLFOCUS, + //LM_ENABLE, + //LM_GETTEXTLENGTH, + //LM_SHOWWINDOW, + //LM_CANCELMODE, + //LM_DRAWITEM, + //LM_MEASUREITEM, + //LM_DELETEITEM, + //LM_VKEYTOITEM, + //LM_CHARTOITEM, + //LM_COMPAREITEM, + //LM_WINDOWPOSCHANGING, + //LM_WINDOWPOSCHANGED, + //LM_NOTIFY, + //LM_HELP, + //LM_NOTIFYFORMAT, + //LM_CONTEXTMENU, + //LM_NCCALCSIZE, + //LM_NCHITTEST, + //LM_NCPAINT, + //LM_NCACTIVATE, + //LM_GETDLGCODE, + LM_NCMOUSEMOVE, + LM_NCLBUTTONDOWN, + LM_NCLBUTTONUP, + LM_NCLBUTTONDBLCLK, + LM_KEYDOWN, + LM_KEYUP, + LM_CHAR, + LM_SYSKEYDOWN, + LM_SYSKEYUP, + LM_SYSCHAR, + LM_COMMAND, + LM_SYSCOMMAND, + LM_TIMER, + LM_HSCROLL, + LM_VSCROLL, + //LM_CTLCOLORMSGBOX, + //LM_CTLCOLOREDIT, + //LM_CTLCOLORLISTBOX, + //LM_CTLCOLORBTN, + //LM_CTLCOLORDLG, + //LM_CTLCOLORSCROLLBAR, + //LM_CTLCOLORSTATIC, + LM_MOUSEMOVE, + LM_LBUTTONDOWN, + LM_LBUTTONUP, + LM_LBUTTONDBLCLK, + LM_RBUTTONDOWN, + LM_RBUTTONUP, + LM_RBUTTONDBLCLK, + LM_MBUTTONDOWN, + LM_MBUTTONUP, + LM_MBUTTONDBLCLK, + LM_MOUSEWHEEL, + LM_XBUTTONDOWN, + LM_XBUTTONUP, + LM_XBUTTONDBLCLK, + //LM_PARENTNOTIFY, + //LM_CAPTURECHANGED, + //LM_DROPFILES, + //LM_SELCHANGE, + LM_CUT, + LM_COPY, + LM_PASTE, + //LM_CLEAR, + //LM_CONFIGUREEVENT, + //LM_EXIT, + //LM_QUIT, + //LM_NULL, + //LM_PAINT, + //LM_ERASEBKGND, + //LM_SETCURSOR, + //LM_SETFONT: + + //CM_ACTIVATE, + //CM_DEACTIVATE, + //CM_FOCUSCHANGED, + //CM_PARENTFONTCHANGED, + //CM_PARENTCOLORCHANGED, + //CM_HITTEST, + //CM_VISIBLECHANGED, + //CM_ENABLEDCHANGED, + //CM_COLORCHANGED, + //CM_FONTCHANGED, + //CM_CURSORCHANGED, + //CM_TEXTCHANGED, + CM_MOUSEENTER, + CM_MOUSELEAVE, + //CM_MENUCHANGED, + //CM_APPSYSCOMMAND, + //CM_BUTTONPRESSED, + //CM_SHOWINGCHANGED, + //CM_ENTER, + //CM_EXIT, + //CM_DESIGNHITTEST, + //CM_ICONCHANGED, + //CM_WANTSPECIALKEY, + //CM_RELEASE, + //CM_FONTCHANGE, + //CM_TABSTOPCHANGED, + //CM_UIACTIVATE, + //CM_CONTROLLISTCHANGE, + //CM_GETDATALINK, + //CM_CHILDKEY, + //CM_HINTSHOW, + //CM_SYSFONTCHANGED, + //CM_CONTROLCHANGE, + //CM_CHANGED, + //CM_BORDERCHANGED, + //CM_BIDIMODECHANGED, + //CM_PARENTBIDIMODECHANGED, + //CM_ALLCHILDRENFLIPPED, + //CM_ACTIONUPDATE, + //CM_ACTIONEXECUTE, + //CM_HINTSHOWPAUSE, + //CM_DOCKNOTIFICATION, + CM_MOUSEWHEEL, + //CM_APPSHOWBTNGLYPHCHANGED, + //CM_APPSHOWMENUGLYPHCHANGED, + + //CN_BASE, + //CN_CHARTOITEM, + //CN_COMMAND, + //CN_COMPAREITEM, + //CN_CTLCOLORBTN, + //CN_CTLCOLORDLG, + //CN_CTLCOLOREDIT, + //CN_CTLCOLORLISTBOX, + //CN_CTLCOLORMSGBOX, + //CN_CTLCOLORSCROLLBAR, + //CN_CTLCOLORSTATIC, + //CN_DELETEITEM, + //CN_DRAWITEM, + CN_HSCROLL, + //CN_MEASUREITEM, + //CN_PARENTNOTIFY, + //CN_VKEYTOITEM, + CN_VSCROLL, + CN_KEYDOWN, + CN_KEYUP, + CN_CHAR, + CN_SYSKEYUP, + CN_SYSKEYDOWN, + CN_SYSCHAR, + CN_NOTIFY: + begin + if Assigned(fTarget) then begin + Message.Result := fTarget.Perform(Message.msg, Message.wParam, Message.lParam); + handled := true; + end; + end; + end; + inherited WndProc(Message); +end; + +{$endregion} + +function CreateOpenGLContextAttrList(UseFB: boolean; pf: TglcContextPixelFormatSettings): TGLIntArray; +var + p: integer; + + procedure Add(i: integer); + begin + SetLength(Result, p+1); + Result[p]:=i; + inc(p); + end; + + procedure CreateList; + begin + if UseFB then begin Add(GLX_X_RENDERABLE); Add(1); end; + if pf.DoubleBuffered then begin + if UseFB then begin + Add(GLX_DOUBLEBUFFER); Add(1); + end else + Add(GLX_DOUBLEBUFFER); + end; + if not UseFB and (pf.ColorBits>24) then Add(GLX_RGBA); + if UseFB then begin + Add(GLX_DRAWABLE_TYPE); + Add(GLX_WINDOW_BIT); + end; + Add(GLX_RED_SIZE); Add(8); + Add(GLX_GREEN_SIZE); Add(8); + Add(GLX_BLUE_SIZE); Add(8); + if pf.ColorBits>24 then + Add(GLX_ALPHA_SIZE); Add(8); + Add(GLX_DEPTH_SIZE); Add(pf.DepthBits); + Add(GLX_STENCIL_SIZE); Add(pf.StencilBits); + Add(GLX_AUX_BUFFERS); Add(pf.AUXBuffers); + + if pf.MultiSampling > 1 then begin + Add(GLX_SAMPLE_BUFFERS_ARB); Add(1); + Add(GLX_SAMPLES_ARB); Add(pf.MultiSampling); + end; + + Add(0); { 0 = X.None (be careful: GLX_NONE is something different) } + end; + +begin + SetLength(Result, 0); + p:=0; + CreateList; +end; + +function FBglXChooseVisual(dpy:PDisplay; screen:longint; attrib_list:Plongint):PXVisualInfo; +type + PGLXFBConfig = ^GLXFBConfig; +var + FBConfigsCount: integer; + FBConfigs: PGLXFBConfig; + FBConfig: GLXFBConfig; +begin + Result:= nil; + FBConfigsCount:=0; + FBConfigs:= glXChooseFBConfig(dpy, screen, attrib_list, @FBConfigsCount); + if FBConfigsCount = 0 then + exit; + + { just choose the first FB config from the FBConfigs list. + More involved selection possible. } + FBConfig := FBConfigs^; + Result:=glXGetVisualFromFBConfig(dpy, FBConfig); +end; + + +{ TglcContextGtk2GLX } + +procedure TglcContextGtk2GLX.UpdateVisual(const aControl: TWinControl); +var + attrList: TGLIntArray; + drawable: PGdkDrawable; +begin + { + Temporary (realized) widget to get to display + } + FWidget:= {%H-}PGtkWidget(PtrUInt(aControl.Handle)); + gtk_widget_realize(FWidget); + drawable:= GTK_WIDGET(FWidget)^.window; + + FDisplay:= GDK_WINDOW_XDISPLAY(drawable); + + { + Find a suitable visual from PixelFormat using GLX 1.3 FBConfigs or + old-style Visuals + } + if Assigned(glXChooseFBConfig) then begin + attrList := CreateOpenGLContextAttrList(true, fPixelFormatSettings); + FVisual := FBglXChooseVisual(FDisplay, DefaultScreen(FDisplay), @attrList[0]); + if not Assigned(FVisual) and (fPixelFormatSettings.MultiSampling > 1) then begin + fPixelFormatSettings.MultiSampling := 1; + attrList := CreateOpenGLContextAttrList(true, fPixelFormatSettings); + FVisual := FBglXChooseVisual(FDisplay, DefaultScreen(FDisplay), @attrList[0]); + end; + end; + if not Assigned(FVisual) then begin + attrList := CreateOpenGLContextAttrList(false, fPixelFormatSettings); + FVisual := glXChooseVisual(FDisplay, DefaultScreen(FDisplay), @attrList[0]); + if not Assigned(FVisual) and (fPixelFormatSettings.MultiSampling > 1) then begin + fPixelFormatSettings.MultiSampling := 1; + attrList := CreateOpenGLContextAttrList(false, fPixelFormatSettings); + FVisual := glXChooseVisual(FDisplay, DefaultScreen(FDisplay), @attrList[0]); + end; + end; + + { + Most widgets inherit the drawable of their parent. In contrast to Windows, descending from + TWinControl does not mean it's actually always a window of its own. + Famous example: TPanel is just a frame painted on a canvas. + Also, the LCL does somethin weird to colormaps in window creation, so we have + to use a custom widget here to have full control about visual selection. + } + FRenderControl:= TRenderControl.Create(aControl, FVisual^.visual^.visualid); + try + FRenderControl.Parent := aControl; + FRenderControl.HandleNeeded; + FRenderControl.Target := aControl; + except + FreeAndNil(FRenderControl); + raise; + end; + + { + Real Widget handle, unrealized!!! + } + FWidget:= FRenderControl.Widget; + gtk_widget_realize(FWidget); + drawable:= GTK_WIDGET(FWidget)^.window; + FDisplay:= GDK_WINDOW_XDISPLAY(drawable); + + // FRenderControl.Align:= alClient breaks the context or something + FRenderControl.BoundsRect := aControl.ClientRect; + FRenderControl.Anchors := [akLeft, akTop, akRight, akBottom]; +end; + +procedure TglcContextGtk2GLX.OpenContext; +var + Attribs: array of GLint; + tmpContext: GLXContext; +begin + inherited OpenContext; + + if not Assigned(FVisual) then + raise EGLXError.Create('Failed to find Visual'); + + tmpContext := glXCreateContext(FDisplay, FVisual, nil, true); + if fUseVersion and + (fVersionSettings.Major <> GLC_CONTEXT_VERSION_UNKNOWN) and + (fVersionSettings.Minor <> GLC_CONTEXT_VERSION_UNKNOWN) then + begin + // Set attributes to describe our requested context + SetLength(Attribs, 5); + Attribs[0] := WGL_CONTEXT_MAJOR_VERSION_ARB; + Attribs[1] := fVersionSettings.Major; + Attribs[2] := WGL_CONTEXT_MINOR_VERSION_ARB; + Attribs[3] := fVersionSettings.Minor; + + // Add context flag for forward compatible context + // Forward compatible means no more support for legacy functions like + // immediate mode (glvertex, glrotate, gltranslate, etc.) + if fVersionSettings.ForwardCompatible then begin + SetLength(Attribs, Length(Attribs)+2); + Attribs[4] := WGL_CONTEXT_FLAGS_ARB; + Attribs[5] := WGL_CONTEXT_FORWARD_COMPATIBLE_BIT_ARB; + end; + + // Attribute flags must be finalized with a zero + SetLength(Attribs, 1); + Attribs[High(Attribs)] := 0; + + glXMakeCurrent(FDisplay, GDK_DRAWABLE_XID(GTK_WIDGET(FWidget)^.window), tmpContext); + ReadImplementationProperties; + if not Assigned(glXCreateContextAttribsARB) or not GLX_ARB_create_context then begin + glXDestroyContext(FDisplay, tmpContext); + raise Exception.Create('GLX_ARB_create_context not supported'); + end; + FContext := glXCreateContextAttribsARB(FDisplay, FVisual, nil, true, @Attribs[0]); + + glXDestroyContext(FDisplay, tmpContext); + end else + FContext := tmpContext; + + if (FContext = nil) then + raise EGLXError.Create('Failed to create Context'); +end; + +constructor TglcContextGtk2GLX.Create(const aControl: TWinControl; + const aPixelFormatSettings: TglcContextPixelFormatSettings); +begin + inherited Create(aControl, aPixelFormatSettings); + UpdateVisual(aControl); +end; + +constructor TglcContextGtk2GLX.Create(const aControl: TWinControl; + const aPixelFormatSettings: TglcContextPixelFormatSettings; + const aVersionSettings: TglcContextVersionSettings); +begin + inherited Create(aControl, aPixelFormatSettings, aVersionSettings); + UpdateVisual(aControl); +end; + +destructor TglcContextGtk2GLX.Destroy; +begin + FreeAndNil(FRenderControl); + XFree(FVisual); + inherited Destroy; +end; + +procedure TglcContextGtk2GLX.CloseContext; +begin + if not Assigned(FWidget) then exit; + if Assigned(FContext) then + glXDestroyContext(FDisplay, FContext); + FreeAndNil(FRenderControl); +end; + +procedure TglcContextGtk2GLX.Activate; +begin + if not Assigned(FWidget) then exit; + // make sure the widget is realized + gtk_widget_realize(FWidget); + if not GTK_WIDGET_REALIZED(FWidget) then exit; + + // make current + + glXMakeCurrent(FDisplay, GDK_DRAWABLE_XID(GTK_WIDGET(FWidget)^.window), FContext); +end; + +procedure TglcContextGtk2GLX.Deactivate; +begin + if not Assigned(FWidget) then exit; + glXMakeCurrent(FDisplay, GDK_DRAWABLE_XID(GTK_WIDGET(FWidget)^.window), nil); +end; + +function TglcContextGtk2GLX.IsActive: boolean; +begin + Result:= (FContext = glXGetCurrentContext()) and + Assigned(FWidget) and + (GDK_DRAWABLE_XID(GTK_WIDGET(FWidget)^.window) = glXGetCurrentDrawable()); +end; + +procedure TglcContextGtk2GLX.SwapBuffers; +var + drawable: PGdkDrawable; +begin + if not Assigned(FWidget) then exit; + drawable:= GTK_WIDGET(FWidget)^.window; + glXSwapBuffers(FDisplay, GDK_DRAWABLE_XID(drawable)); +end; + +procedure TglcContextGtk2GLX.SetSwapInterval(const aInterval: GLint); +var + drawable: PGdkDrawable; +begin + drawable:= GTK_WIDGET(FWidget)^.window; + if GLX_EXT_swap_control then + glXSwapIntervalEXT(FDisplay, GDK_WINDOW_XWINDOW(drawable), aInterval); +end; + +procedure TglcContextGtk2GLX.Share(const aContext: TglcContext); +begin + raise Exception.Create('not yet implemented'); +end; + +class function TglcContextGtk2GLX.ChangeDisplaySettings(const aWidth, aHeight, + aBitPerPixel, aFreq: Integer; const aFlags: TglcDisplayFlags): Boolean; +begin + raise Exception.Create('not yet implemented'); +end; + +class function TglcContextGtk2GLX.IsAnyContextActive: boolean; +begin + Result:= (glXGetCurrentContext()<>nil) and (glXGetCurrentDrawable()<>0); +end; + +end. + \ No newline at end of file diff --git a/uglcContextGtkCustomVisual.pas b/uglcContextGtkCustomVisual.pas new file mode 100644 index 0000000..ffc8677 --- /dev/null +++ b/uglcContextGtkCustomVisual.pas @@ -0,0 +1,225 @@ +unit uglcContextGtkCustomVisual; + +{ Package: OpenGLCore + Prefix: glc - OpenGL Core + Beschreibung: diese Unit enthält Klassen zum Erzeugen von Visuals (unter Linux), + auf denen ein OpenGL Kontext erstellt werden kann } + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Controls, LCLType, InterfaceBase, LMessages, WSLCLClasses, WSControls, + X, XLib, glib2, gdk2, gdk2x, gtk2, Gtk2Def, Gtk2Int; + +type + TCustomVisualControl = class(TWinControl) + private + FIntWidget: PGtkWidget; + FVisualID: TVisualID; + protected + function WSCreateHandle({%H-}const WSPrivate: TWSPrivateClass; const AParams: TCreateParams): TLCLIntfHandle; + procedure WSBeforeDestroyHandle; + public + constructor Create(TheOwner: TComponent; const aVisualID: TVisualID); overload; + property Widget: PGtkWidget read FIntWidget; + end; + + + TWSCustomVisualControl = class(TWSWinControl) + published + class function CreateHandle(const AWinControl: TWinControl; + const AParams: TCreateParams): TLCLIntfHandle; override; + class procedure DestroyHandle(const AWinControl: TWinControl); override; + end; + + +implementation + +type + PGtkCustomWidget = ^TGtkCustomWidget; + TGtkCustomWidget = record + darea: TGtkDrawingArea; + end; + + PGtkCustomWidgetClass = ^TGtkCustomWidgetClass; + TGtkCustomWidgetClass = record + parent_class: TGtkDrawingAreaClass; + end; + +var + custom_widget_type: TGtkType = 0; + custom_widget_parent_class: Pointer = nil; + +function GTK_TYPE_CUSTOM_WIDGET: TGtkType; forward; + + +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 GTK_IS_CUSTOM_WIDGET(obj: Pointer): Boolean; +begin + GTK_IS_CUSTOM_WIDGET:=GTK_CHECK_TYPE(obj,GTK_TYPE_CUSTOM_WIDGET); +end; + +function GTK_CUSTOM_WIDGET(obj: Pointer): PGtkCustomWidget; +begin + g_return_if_fail(GTK_IS_CUSTOM_WIDGET(obj),''); + Result:=PGtkCustomWidget(obj); +end; + +procedure gtk_custom_widget_init(custom_widget: PGTypeInstance; theClass: gpointer); cdecl; +begin + if theClass=nil then ; + //DebugLn(['gtk_custom_widget_init START']); + gtk_widget_set_double_buffered(PGtkWidget(custom_widget),gdkFALSE); + GTK_WIDGET_UNSET_FLAGS(PGtkWidget(custom_widget),GTK_NO_WINDOW); + //DebugLn(['gtk_custom_widget_init END']); +end; + +procedure gtk_custom_widget_destroy(obj: PGtkObject); cdecl; +begin + g_return_if_fail (obj <>nil,''); + g_return_if_fail (GTK_IS_CUSTOM_WIDGET(obj),''); + + if Assigned(GTK_OBJECT_CLASS(custom_widget_parent_class)^.destroy) then + GTK_OBJECT_CLASS(custom_widget_parent_class)^.destroy(obj); +end; + +procedure gtk_custom_widget_class_init(klass: Pointer); cdecl; +var + object_class: PGtkObjectClass; +begin + custom_widget_parent_class := gtk_type_class(gtk_drawing_area_get_type()); + g_return_if_fail(custom_widget_parent_class<>nil,'gtk_custom_widget_class_init parent_class=nil'); + object_class := PGtkObjectClass(klass); + g_return_if_fail(object_class<>nil,'gtk_custom_widget_class_init object_class=nil'); + + object_class^.destroy := @gtk_custom_widget_destroy; +end; + +function custom_widget_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; + +function GTK_TYPE_CUSTOM_WIDGET: TGtkType; +const + custom_widget_type_name = 'GtkGLArea'; + custom_widget_info: TGtkTypeInfo = ( + type_name: custom_widget_type_name; + object_size: SizeOf(TGtkCustomWidget); + class_size: SizeOf(TGtkCustomWidgetClass); + class_init_func: @gtk_custom_widget_class_init; + object_init_func: @gtk_custom_widget_init; + reserved_1: nil; + reserved_2: nil; + base_class_init_func: nil; + ); +begin + if (custom_widget_type=0) then begin + custom_widget_type:=gtk_type_unique(gtk_drawing_area_get_type(),@custom_widget_info); + end; + Result:=custom_widget_type; +end; + +{ TCustomVisualControl } + +constructor TCustomVisualControl.Create(TheOwner: TComponent; const aVisualID: TVisualID); +begin + inherited Create(TheOwner); + FIntWidget:= nil; + fVisualID:= aVisualID; + SetBounds(0, 0, 200, 200); +end; + +function TCustomVisualControl.WSCreateHandle(const WSPrivate: TWSPrivateClass; const AParams: TCreateParams): TLCLIntfHandle; +var + cmap: PGdkColormap; + gdkvis: PGdkVisual; +begin + // is the requested VisualID different from what the widget would get? + cmap := gdk_colormap_get_system; + gdkvis:= gdk_colormap_get_visual(cmap); + if XVisualIDFromVisual(gdk_x11_visual_get_xvisual(gdkvis)) <> FVisualID then begin + gdkvis:= gdkx_visual_get(FVisualID); + cmap := gdk_colormap_new(gdkvis, false); + end; + + FIntWidget:= gtk_type_new(GTK_TYPE_CUSTOM_WIDGET); + gtk_widget_set_colormap(FIntWidget, cmap); + + Result:= TLCLIntfHandle({%H-}PtrUInt(FIntWidget)); + PGtkobject(FIntWidget)^.flags:= PGtkobject(FIntWidget)^.flags or GTK_CAN_FOCUS; + TGTK2WidgetSet(WidgetSet).FinishCreateHandle(Self,FIntWidget,AParams); + g_signal_connect_after(FIntWidget, 'size-allocate', TGTKSignalFunc(@custom_widget_size_allocateCB), Self); +end; + +procedure TCustomVisualControl.WSBeforeDestroyHandle; +begin + if not HandleAllocated then exit; +end; + + +{ TWSCustomVisualControl } + +class function TWSCustomVisualControl.CreateHandle(const AWinControl: TWinControl; const AParams: TCreateParams): TLCLIntfHandle; +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 + Result:= (AWinControl as TCustomVisualControl).WSCreateHandle(WSPrivate, AParams); +end; + +class procedure TWSCustomVisualControl.DestroyHandle(const AWinControl: TWinControl); +begin + (AWinControl as TCustomVisualControl).WSBeforeDestroyHandle; + // do not use "inherited DestroyHandle", because the LCL changes the hierarchy at run time + TWSWinControlClass(ClassParent).DestroyHandle(AWinControl); +end; + +initialization + RegisterWSComponent(TCustomVisualControl,TWSCustomVisualControl); + +end. + diff --git a/uglcContextWGL.pas b/uglcContextWGL.pas new file mode 100644 index 0000000..76e0614 --- /dev/null +++ b/uglcContextWGL.pas @@ -0,0 +1,432 @@ +unit uglcContextWGL; + +{ Package: OpenGLCore + Prefix: glc - OpenGL Core + Beschreibung: diese Unit enthält eine Klassen-Kapselung für OpenGL Kontexte für Windows + Hint: diese Unit sollte niemals direkt genutzt werden (siehe uglcContext) } + +interface + +uses + Classes, SysUtils, Forms, Windows, uglcContext, dglOpenGL, Controls; + +type + EWGLError = class(EGLError); + + { TglcContextWGL } + + TglcContextWGL = class(TglcContext) + private + FDC: HDC; + FRC: HGLRC; + fHandle: THandle; + fPixelFormat: Integer; + {%H-}constructor Create(const aControl: TWinControl); + protected + procedure UpdatePixelFormat; + procedure OpenContext; override; + function FindPixelFormat: Integer; + function FindPixelFormatNoAA: Integer; + procedure OpenFromPF(PixelFormat: Integer); + public + constructor Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings); override; overload; + constructor Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings; const aVersionSettings: TglcContextVersionSettings); override; overload; + + procedure CloseContext; override; + procedure Activate; override; + procedure Deactivate; override; + function IsActive: boolean; override; + procedure SwapBuffers; override; + procedure SetSwapInterval(const aInterval: GLint); override; + function GetSwapInterval: GLint; override; + procedure Share(const aContext: TglcContext); override; + + class function ChangeDisplaySettings(const aWidth, aHeight, aBitPerPixel, aFreq: Integer; + const aFlags: TglcDisplayFlags): Boolean; override; + class function IsAnyContextActive: boolean; override; + end; + +implementation + +{ TglcContextWGL } + +constructor TglcContextWGL.Create(const aControl: TWinControl); +begin + inherited Create(aControl, MakePF()); + fHandle := aControl.Handle; +end; + +procedure TglcContextWGL.UpdatePixelFormat; +begin + fPixelFormat := FindPixelFormat; + if (fPixelFormat = 0) then begin + // try without MS + fPixelFormatSettings.MultiSampling := 1; + fPixelFormat := FindPixelFormat; + end; +end; + +procedure TglcContextWGL.OpenContext; +begin + inherited OpenContext; + OpenFromPF(fPixelFormat); +end; + +function TglcContextWGL.FindPixelFormat: Integer; +var + OldRC: HGLRC; OldDC: HDC; + tmpWnd: TForm; + tmpContext: TglcContextWGL; + pf, i, max: integer; + Count: GLuint; + PFList, SampleList: array[0..31] of GLint; + + procedure ChoosePF(pPFList, pSampleList: PGLint; MaxCount: integer); + var + //ARB_Erweiterung vorhanden + //| EXT_Erweiterung vorhanden + MultiARBSup, MultiEXTSup: Boolean; + //Liste der Integer Attribute + IAttrib: array[0..22] of GLint; + //Liste der Float Attribute (nur 0, da kein Wert) + FAttrib: GLFloat; + QueryAtrib, i: Integer; + PPosiblePF, PSample: PglInt; + begin + //Pixelformate mit AA auslesen + MultiARBSup := false; + MultiEXTSup := false; + if WGL_ARB_extensions_string and + WGL_ARB_pixel_format and + (WGL_ARB_MULTISAMPLE or GL_ARB_MULTISAMPLE) then + multiARBSup := true; + if WGL_EXT_extensions_string and + WGL_EXT_pixel_format and + (WGL_EXT_MULTISAMPLE or GL_EXT_MULTISAMPLE) then + multiEXTSup := true; + + if multiARBSup then + Read_WGL_ARB_pixel_format + else if multiEXTSup then + Read_WGL_EXT_pixel_format; + + if not (MultiARBSup or MultiEXTSup) then + exit; + + IAttrib[00] := WGL_DRAW_TO_WINDOW_ARB; + IAttrib[01] := 1; + + IAttrib[02] := WGL_SUPPORT_OPENGL_ARB; + IAttrib[03] := 1; + + IAttrib[04] := WGL_DOUBLE_BUFFER_ARB; + if (fPixelFormatSettings.DoubleBuffered) then + IAttrib[05] := 1 + else + IAttrib[05] := 0; + + IAttrib[06] := WGL_PIXEL_TYPE_ARB; + IAttrib[07] := WGL_TYPE_RGBA_ARB; + + IAttrib[08] := WGL_COLOR_BITS_ARB; + IAttrib[09] := fPixelFormatSettings.ColorBits; + + IAttrib[10] := WGL_ALPHA_BITS_ARB; + IAttrib[11] := 0; //TODO: fPixelFormatSettings.AlphaBits; + + IAttrib[12] := WGL_DEPTH_BITS_ARB; + IAttrib[13] := fPixelFormatSettings.DepthBits; + + IAttrib[14] := WGL_STENCIL_BITS_ARB; + IAttrib[15] := fPixelFormatSettings.StencilBits; + + IAttrib[16] := WGL_ACCUM_BITS_ARB; + IAttrib[17] := fPixelFormatSettings.AccumBits; + + IAttrib[18] := WGL_AUX_BUFFERS_ARB; + IAttrib[19] := fPixelFormatSettings.AuxBuffers; + + IAttrib[20] := WGL_SAMPLE_BUFFERS_ARB; + IAttrib[21] := 1; + + IAttrib[22] := 0; + FAttrib := 0; + + if multiARBSup then + wglChoosePixelFormatARB(tmpContext.FDC, @IAttrib[0], @FAttrib, MaxCount, pPFList, @Count) + else if multiEXTSup then + wglChoosePixelFormatEXT(tmpContext.FDC, @IAttrib[0], @FAttrib, MaxCount, pPFList, @Count); + + if Count > length(PFList) then + Count := length(PFList); + + QueryAtrib := WGL_SAMPLES_ARB; + PSample := pSampleList; + PPosiblePF := @PFList[0]; + for i := 0 to Count-1 do begin + if multiARBSup then + wglGetPixelFormatAttribivARB(tmpContext.FDC, PPosiblePF^, 0, 1, @QueryAtrib, PSample) + else if multiEXTSup then + wglGetPixelFormatAttribivEXT(tmpContext.FDC, PPosiblePF^, 0, 1, @QueryAtrib, PSample); + inc(PSample); + inc(PPosiblePF); + end; + end; +begin + if (fPixelFormatSettings.MultiSampling = 1) then begin + Result := FindPixelFormatNoAA; + exit; + end; + Result := 0; + OldDC := wglGetCurrentDC(); + OldRC := wglGetCurrentContext(); + try + tmpWnd := TForm.Create(nil); + tmpContext := TglcContextWGL.Create(tmpWnd); + try + pf := tmpContext.FindPixelFormatNoAA; + tmpContext.OpenFromPF(pf); + tmpContext.Activate; + + FillChar({%H-}PFList[0], Length(PFList), 0); + FillChar({%H-}SampleList[0], Length(SampleList), 0); + ChoosePF(@PFList[0], @SampleList[0], length(SampleList)); + max := 0; + for i := 0 to Count-1 do begin + if (max < SampleList[i]) and (SampleList[i] <= fPixelFormatSettings.MultiSampling) and (PFList[i] <> 0) then begin + max := SampleList[i]; + result := PFList[i]; + if (max = fPixelFormatSettings.MultiSampling) then + break; + end; + end; + tmpContext.Deactivate; + finally + FreeAndNil(tmpContext); + FreeAndNil(tmpWnd); + end; + finally + if (OldDC <> 0) and (OldRC <> 0) then + ActivateRenderingContext(OldDC, OldRC); + end; +end; + +function TglcContextWGL.FindPixelFormatNoAA: Integer; +const + MemoryDCs = [OBJ_MEMDC, OBJ_METADC, OBJ_ENHMETADC]; +var + //DeviceContext + DC: HDC; + //Objekttyp des DCs + AType: DWord; + //Beschreibung zum passenden Pixelformat + PFDescriptor: TPixelFormatDescriptor; +begin + result := 0; + DC := GetDC(fHandle); + if DC = 0 then begin + exit; + end; + FillChar(PFDescriptor{%H-}, SizeOf(PFDescriptor), #0); + with PFDescriptor do begin + nSize := SizeOf(PFDescriptor); + nVersion := 1; + dwFlags := PFD_SUPPORT_OPENGL; + AType := GetObjectType(DC); + if AType = 0 then begin + exit; + end; + if fPixelFormatSettings.DoubleBuffered then + dwFlags := dwFlags or PFD_DOUBLEBUFFER; + if fPixelFormatSettings.Stereo then + dwFlags := dwFlags or PFD_STEREO; + if AType in MemoryDCs then + dwFlags := dwFlags or PFD_DRAW_TO_BITMAP + else + dwFlags := dwFlags or PFD_DRAW_TO_WINDOW; + + iPixelType := PFD_TYPE_RGBA; + cColorBits := fPixelFormatSettings.ColorBits; +//TODO: cAlphaBits := fPixelFormatSettings.AlphaBits; + cDepthBits := fPixelFormatSettings.DepthBits; + cStencilBits := fPixelFormatSettings.StencilBits; + cAccumBits := fPixelFormatSettings.AccumBits; + cAuxBuffers := fPixelFormatSettings.AuxBuffers; + + if fPixelFormatSettings.Layer = 0 then + iLayerType := PFD_MAIN_PLANE + else if fPixelFormatSettings.Layer > 0 then + iLayerType := PFD_OVERLAY_PLANE + else + iLayerType := Byte(PFD_UNDERLAY_PLANE); + end; + result := ChoosePixelFormat(DC, @PFDescriptor); +end; + +procedure TglcContextWGL.OpenFromPF(PixelFormat: Integer); +var + tmpRC: HGLRC; + Attribs: array of GLint; + CreateContextAttribs: TwglCreateContextAttribsARB; +begin + if PixelFormat = 0 then begin + raise EWGLError.Create('Invalid PixelFormat'); + end; + + FDC := GetDC(fHandle); + if FDC = 0 then begin + raise EWGLError.CreateFmt('Cannot create DC on %x',[fHandle]); + end; + + if not SetPixelFormat(FDC, PixelFormat, nil) then begin + ReleaseDC(fHandle, FDC); + raise EWGLError.CreateFmt('Cannot set PF %d on Control %x DC %d',[PixelFormat, fHandle, FDC]); + end; + + tmpRC := wglCreateContext(FDC); + if tmpRC = 0 then begin + ReleaseDC(fHandle, FDC); + raise EWGLError.CreateFmt('Cannot create context on Control %x DC %d',[PixelFormat, fHandle, FDC]); + end; + + if fUseVersion and + (fVersionSettings.Major <> GLC_CONTEXT_VERSION_UNKNOWN) and + (fVersionSettings.Minor <> GLC_CONTEXT_VERSION_UNKNOWN) then + begin + { Code from dglOpenGL.pas (modified) } + wglMakeCurrent(FDC, tmpRC); + + // Set attributes to describe our requested context + SetLength(Attribs, 5); + Attribs[0] := WGL_CONTEXT_MAJOR_VERSION_ARB; + Attribs[1] := fVersionSettings.Major; + Attribs[2] := WGL_CONTEXT_MINOR_VERSION_ARB; + Attribs[3] := fVersionSettings.Minor; + + // Add context flag for forward compatible context + // Forward compatible means no more support for legacy functions like + // immediate mode (glvertex, glrotate, gltranslate, etc.) + if fVersionSettings.ForwardCompatible then begin + SetLength(Attribs, Length(Attribs)+2); + Attribs[4] := WGL_CONTEXT_FLAGS_ARB; + Attribs[5] := WGL_CONTEXT_FORWARD_COMPATIBLE_BIT_ARB; + end; + + // Attribute flags must be finalized with a zero + Attribs[High(Attribs)] := 0; + + // Get function pointer for new context creation function + CreateContextAttribs := TwglCreateContextAttribsARB(wglGetProcAddress('wglCreateContextAttribsARB')); + if not Assigned(CreateContextAttribs) then begin + wglMakeCurrent(0, 0); + wglDeleteContext(tmpRC); + ReleaseDC(fHandle, FDC); + raise Exception.Create('Could not get function pointer adress for wglCreateContextAttribsARB - OpenGL 3.x and above not supported!'); + end; + + // Create context + FRC := CreateContextAttribs(FDC, 0, @Attribs[0]); + if (FRC = 0) then begin + wglMakeCurrent(0, 0); + wglDeleteContext(tmpRC); + ReleaseDC(fHandle, FDC); + raise Exception.Create('Could not create the desired OpenGL rendering context!'); + end; + + wglMakeCurrent(0, 0); + wglDeleteContext(tmpRC); + end else + FRC := tmpRC; +end; + +constructor TglcContextWGL.Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings); +begin + inherited Create(aControl, aPixelFormatSettings); + fHandle := aControl.Handle; + UpdatePixelFormat; +end; + +constructor TglcContextWGL.Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings; const aVersionSettings: TglcContextVersionSettings); +begin + inherited Create(aControl, aPixelFormatSettings, aVersionSettings); + fHandle := aControl.Handle; + UpdatePixelFormat; +end; + +procedure TglcContextWGL.CloseContext; +begin + if (FRC <> 0) then begin + Deactivate; + DestroyRenderingContext(FRC); + ReleaseDC(fHandle, FDC); + FRC := 0; + FDC := 0; + end; +end; + +procedure TglcContextWGL.Activate; +begin + ActivateRenderingContext(FDC, FRC); +end; + +procedure TglcContextWGL.Deactivate; +begin + if wglGetCurrentContext()=FRC then + DeactivateRenderingContext; +end; + +function TglcContextWGL.IsActive: boolean; +begin + Result:= (FRC <> 0) and + (FRC = wglGetCurrentContext()) and + (FDC = wglGetCurrentDC()); +end; + +procedure TglcContextWGL.SwapBuffers; +begin + Windows.SwapBuffers(FDC); +end; + +procedure TglcContextWGL.SetSwapInterval(const aInterval: GLint); +begin + wglSwapIntervalEXT(aInterval); +end; + +function TglcContextWGL.GetSwapInterval: GLint; +begin + result := wglGetSwapIntervalEXT(); +end; + +procedure TglcContextWGL.Share(const aContext: TglcContext); +begin + wglShareLists(FRC, (aContext as TglcContextWGL).FRC); +end; + +class function TglcContextWGL.ChangeDisplaySettings(const aWidth, aHeight, + aBitPerPixel, aFreq: Integer; const aFlags: TglcDisplayFlags): Boolean; +var + dm: TDeviceMode; + flags: Cardinal; +begin + FillChar(dm{%H-}, SizeOf(dm), 0); + with dm do begin + dmSize := SizeOf(dm); + dmPelsWidth := aWidth; + dmPelsHeight := aHeight; + dmDisplayFrequency := aFreq; + dmBitsPerPel := aBitPerPixel; + dmFields := DM_PELSWIDTH or DM_PELSHEIGHT or DM_BITSPERPEL or DM_DISPLAYFREQUENCY; + end; + flags := 0; //CDS_TEST; + if (dfFullscreen in aFlags) then + flags := flags or CDS_FULLSCREEN; + result := (Windows.ChangeDisplaySettings(dm, flags) = DISP_CHANGE_SUCCESSFUL); +end; + +class function TglcContextWGL.IsAnyContextActive: boolean; +begin + Result:= (wglGetCurrentContext()<>0) and (wglGetCurrentDC()<>0); +end; + +end. + -- 2.1.4