Browse Source

* added glcContext

master
Bergmann89 9 years ago
parent
commit
07d4b69c6a
4 changed files with 1463 additions and 0 deletions
  1. +244
    -0
      uglcContext.pas
  2. +562
    -0
      uglcContextGtk2GLX.pas
  3. +225
    -0
      uglcContextGtkCustomVisual.pas
  4. +432
    -0
      uglcContextWGL.pas

+ 244
- 0
uglcContext.pas View File

@@ -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.


+ 562
- 0
uglcContextGtk2GLX.pas View File

@@ -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.

+ 225
- 0
uglcContextGtkCustomVisual.pas View File

@@ -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.


+ 432
- 0
uglcContextWGL.pas View File

@@ -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.


Loading…
Cancel
Save