|
- 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
- {$IFNDEF fpc}
- TThreadID = Cardinal;
- {$ENDIF}
-
- 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;
- TSeverity = (svLow, svMedium, svHigh);
- TLogEvent = procedure(const aSender: TObject; const aSeverity: TSeverity; const aMsg: String) of Object;
-
- TglcDisplayFlag = (
- dfFullscreen);
- TglcDisplayFlags = set of TglcDisplayFlag;
-
- EGLError = class(Exception);
-
- { TglcContext }
- TglcContextClass = class of TglcContext;
- TglcContext = class
- private
- fControl: TWinControl;
- fThreadID: TThreadID;
- fEnableVsync: Boolean;
- fLogEvent: TLogEvent;
- fShareContext: TglcContext;
-
- function GetEnableVSync: Boolean;
- procedure SetEnableVSync(aValue: Boolean);
- procedure LogMsg(const aSeverity: TSeverity; const aMsg: String);
- procedure SetDebugMode(const aEnable: Boolean);
- protected
- fUseVersion: Boolean;
- fPixelFormatSettings: TglcContextPixelFormatSettings;
- fVersionSettings: TglcContextVersionSettings;
- procedure OpenContext; virtual;
-
- public
- property PixelFormatSettings: TglcContextPixelFormatSettings read fPixelFormatSettings;
- property VersionSettings: TglcContextVersionSettings read fVersionSettings;
- property ShareContext: TglcContext read fShareContext;
-
- constructor Create(const aControl: TWinControl;
- const aPixelFormatSettings: TglcContextPixelFormatSettings;
- const aShareContext: TglcContext = nil); overload; virtual;
- constructor Create(const aControl: TWinControl;
- const aPixelFormatSettings: TglcContextPixelFormatSettings;
- const aVersionSettings: TglcContextVersionSettings;
- const aShareContext: TglcContext = nil); overload; virtual;
- destructor Destroy; override;
-
- property ThreadID: TThreadID read fThreadID;
- property EnableVSync: Boolean read GetEnableVSync write SetEnableVSync;
-
- procedure BuildContext;
- procedure EnableDebugOutput(const aLogEvent: TLogEvent);
- procedure DisableDebugOutput;
- procedure CloseContext; virtual;
- procedure ReleaseShareContext; virtual;
- procedure Activate; virtual;
- 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;
- {$IFDEF fpc}
- private class var
- fMainContextThreadID: TThreadID;
- public
- class property MainContextThreadID: TThreadID read fMainContextThreadID;
- {$ENDIF}
- public
- 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
- {$ELSE}{$IFDEF WIN32}
- uglcContextWGL{$IFNDEF fpc}, Windows{$ENDIF}
- {$ENDIF}{$ENDIF}
-
- {$IFDEF LINUX}
- uglcContextGtk2GLX
- {$ENDIF}
- ;
-
- {$IFNDEF fpc}
- var
- fMainContextThreadID: TThreadID;
- {$ENDIF}
-
- procedure GlDebugCallbackARB(source: GLenum; type_: GLenum; id: GLuint; severity: GLenum; {%H-}length: GLsizei; const message_: PGLchar; {%H-}userParam: PGLvoid); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF}
- var
- src, typ: String;
- sv: TSeverity;
- begin
- case source of
- GL_DEBUG_SOURCE_API_ARB : src:= 'API';
- GL_DEBUG_SOURCE_WINDOW_SYSTEM_ARB : src:= 'WINDOW';
- GL_DEBUG_SOURCE_SHADER_COMPILER_ARB: src:= 'SHADER';
- GL_DEBUG_SOURCE_THIRD_PARTY_ARB : src:= '3RDPARTY';
- GL_DEBUG_SOURCE_APPLICATION_ARB : src:= 'APPLICATION';
- GL_DEBUG_SOURCE_OTHER_ARB : src:= 'OTHER';
- end;
- src:= 'GL_' + src;
-
- case type_ of
- GL_DEBUG_TYPE_ERROR_ARB : typ:= 'ERROR';
- GL_DEBUG_TYPE_DEPRECATED_BEHAVIOR_ARB : typ:= 'DEPRECATED';
- GL_DEBUG_TYPE_UNDEFINED_BEHAVIOR_ARB : typ:= 'UNDEF BEHAV';
- GL_DEBUG_TYPE_PORTABILITY_ARB : typ:= 'PORTABILITY';
- GL_DEBUG_TYPE_PERFORMANCE_ARB : typ:= 'PERFORMANCE';
- GL_DEBUG_TYPE_OTHER_ARB : typ:= 'OTHER';
- end;
-
- case severity of
- GL_DEBUG_SEVERITY_LOW_ARB: sv := svLow;
- GL_DEBUG_SEVERITY_MEDIUM_ARB: sv := svMedium;
- GL_DEBUG_SEVERITY_HIGH_ARB: sv := svHigh;
- end;
-
- TglcContext(userParam).LogMsg(sv, format('%s [%d] %s',[typ, id, message_]));
- end;
-
- procedure GlDebugCallbackAMD(id: GLuint; category: GLenum; severity: GLenum; {%H-}length: GLsizei; const message_: PGLchar; {%H-}userParam: PGLvoid); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF}
- var
- src: String;
- sv: TSeverity;
- begin
- case category of
- GL_DEBUG_CATEGORY_API_ERROR_AMD : src:= 'API';
- GL_DEBUG_CATEGORY_WINDOW_SYSTEM_AMD : src:= 'WINDOW';
- GL_DEBUG_CATEGORY_DEPRECATION_AMD : src:= 'SHADER';
- GL_DEBUG_CATEGORY_UNDEFINED_BEHAVIOR_AMD : src:= 'UNDEF BEHAV';
- GL_DEBUG_CATEGORY_PERFORMANCE_AMD : src:= 'PERFORMANCE';
- GL_DEBUG_CATEGORY_SHADER_COMPILER_AMD : src:= 'SHADER';
- GL_DEBUG_CATEGORY_APPLICATION_AMD : src:= 'APPLICATION';
- GL_DEBUG_CATEGORY_OTHER_AMD : src:= 'OTHER';
- end;
- src:= 'GL_' + src;
-
- case severity of
- GL_DEBUG_SEVERITY_LOW_AMD: sv := svLow;
- GL_DEBUG_SEVERITY_MEDIUM_AMD: sv := svMedium;
- GL_DEBUG_SEVERITY_HIGH_AMD: sv := svHigh;
- end;
-
- TglcContext(userParam).LogMsg(sv, format('[%d] %s',[id, message_]));
- end;
-
- 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.LogMsg(const aSeverity: TSeverity; const aMsg: String);
- begin
- if Assigned(fLogEvent) then
- fLogEvent(self, aSeverity, aMsg);
- end;
-
- procedure TglcContext.SetDebugMode(const aEnable: Boolean);
- begin
- // ARB Debug Output
- if GL_ARB_debug_output then begin
- glDebugMessageCallbackARB(@GlDebugCallbackARB, self);
- glDebugMessageControlARB(GL_DONT_CARE, GL_DONT_CARE, GL_DONT_CARE, 0, nil, aEnable);
- if aEnable then begin
- glEnable(GL_DEBUG_OUTPUT_SYNCHRONOUS_ARB);
- glDebugMessageInsertARB(GL_DEBUG_SOURCE_APPLICATION_ARB, GL_DEBUG_TYPE_OTHER_ARB, 0, GL_DEBUG_SEVERITY_LOW_ARB, -1, PGLchar('Attached ARB_debug_output'));
- end;
-
- // AMD Debug Output
- end else if GL_AMD_debug_output then begin
- glDebugMessageCallbackAMD(@GlDebugCallbackAMD, self);
- glDebugMessageEnableAMD(GL_DONT_CARE, GL_DONT_CARE, 0, nil, aEnable);
- if aEnable then
- glDebugMessageInsertAMD(GL_DEBUG_CATEGORY_OTHER_AMD, GL_DEBUG_SEVERITY_LOW_ARB, 0, -1, PGLchar('Attached ARB_debug_output'));
- 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
- Result := nil;
- {$IFDEF WINDOWS}
- Result:= TglcContextWGL;
- {$ELSE}{$IFDEF WIN32}
- Result:= TglcContextWGL;
- {$ENDIF}{$ENDIF}
- {$IFDEF LINUX}
- Result:= TglcContextGtk2GLX;
- {$ENDIF}
- if not Assigned(result) then
- raise EGLError.Create('unable to find suitabe context class');
- end;
-
- class function TglcContext.IsAnyContextActive: boolean;
- begin
- Result:= GetPlatformClass.IsAnyContextActive;
- end;
-
- constructor TglcContext.Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings; const aShareContext: TglcContext);
- begin
- inherited Create;
- fShareContext := aShareContext;
- fPixelFormatSettings := aPixelFormatSettings;
- FControl := aControl;
- fThreadID := 0;
- fEnableVsync := false;
- fUseVersion := false;
- InitOpenGL();
- end;
-
- constructor TglcContext.Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings; const aVersionSettings: TglcContextVersionSettings; const aShareContext: TglcContext);
- begin
- Create(aControl, aPixelFormatSettings, aShareContext);
- 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;
- SetEnableVSync(fEnableVsync);
- end;
-
- procedure TglcContext.EnableDebugOutput(const aLogEvent: TLogEvent);
- begin
- fLogEvent := aLogEvent;
- SetDebugMode(true);
- end;
-
- procedure TglcContext.DisableDebugOutput;
- begin
- SetDebugMode(false);
- end;
-
- procedure TglcContext.CloseContext;
- begin
- if fMainContextThreadID = fThreadID then
- fMainContextThreadID := 0;
- end;
-
- procedure TglcContext.ReleaseShareContext;
- begin
- fShareContext := nil;
- end;
-
- procedure TglcContext.Activate;
- begin
- ReadImplementationProperties;
- ReadExtensions;
- end;
-
- initialization
- {$IFDEF fpc}TglcContext.{$ENDIF}fMainContextThreadID := 0;
-
- end.
|