uglcContext.pas

   1 unit uglcContext;
   2
   3 { Package:      OpenGLCore
   4   Prefix:       glc - OpenGL Core
   5   Beschreibung: diese Unit enthält eine abstrakte Klassen-Kapselung für OpenGL Kontexte
   6
   7
   8 Abstrakte Contextklasse zum Erstellen von Renderkontexten auf Windows & Linux(bzw X11/Gtk2)
   9 Für aktuelle Plattform passende Klasse kann per GetPlatformClass gefunden werden.
  10
  11 Bsp.:
  12   //muss im GUI/Main-Thread aufgerufen werden:
  13   pf := TglcContext.GetPlatformClass().MakePF();
  14   fContext := TglcContext.GetPlatformClass().Create(MyTWinControl, PF);
  15
  16   //_kann_ in Background Thread abgerufen werden:
  17   fContext.BuildContext();
  18   [Arbeit mit dem Context]
  19   fContext.CloseContext();
  20
  21   //im MainThread
  22   FreeAndNil(fContext)
  23
  24
  25 weitere Funktionen:
  26   MakePF()             erzeugt PixelFormatDescriptor mit Defaults
  27   BuildContext()       baut Kontext (kann in BackgrounThread aufgerufen werden)
  28   CloseContext()       gibt den Kontext frei (muss im selben Thread aufgerufen werden wie BuildContext;
  29                        wird der Kontext nur im MainThread genutzt, muss CloseContext nicht explizit aufgerufen
  30                        werden und wird beim zerstören des Kontext-Objekts ausgeführt)
  31   Activate/Deactiveate Kontext aktiv schalten oder nicht
  32   SwapBuffers          DoubleBuffering
  33   SetSwapInterval      VSync
  34   Share                ShareLists
  35   EnableDebugOutput    GL-Debug via ARB_debug_output oder AMD_debug_output de/aktivieren
  36 }
  37
  38 interface
  39
  40 uses
  41   SysUtils, Controls, dglOpenGL;
  42
  43 const
  44   GLC_CONTEXT_VERSION_UNKNOWN = -1;
  45
  46 type
  47   TMultiSample = 1..high(byte);
  48   TglcContextPixelFormatSettings = packed record
  49     DoubleBuffered: boolean;
  50     Stereo: boolean;
  51     MultiSampling: TMultiSample;
  52     ColorBits: Integer;
  53     DepthBits: Integer;
  54     StencilBits: Integer;
  55     AccumBits: Integer;
  56     AuxBuffers: Integer;
  57     Layer: Integer;
  58   end;
  59   TglcContextVersionSettings = packed record
  60     Major: Integer;
  61     Minor: Integer;
  62     ForwardCompatible: Boolean;
  63   end;
  64   TSeverity = (svLow, svMedium, svHigh);
  65   TLogEvent = procedure(const aSender: TObject; const aSeverity: TSeverity; const aMsg: String) of Object;
  66
  67   TglcDisplayFlag = (
  68     dfFullscreen);
  69   TglcDisplayFlags = set of TglcDisplayFlag;
  70
  71   EGLError = class(Exception);
  72
  73   { TglcContext }
  74   TglcContextClass = class of TglcContext;
  75   TglcContext = class
  76   private
  77     fControl: TWinControl;
  78     fThreadID: TThreadID;
  79     fEnableVsync: Boolean;
  80     fLogEvent: TLogEvent;
  81
  82     function GetEnableVSync: Boolean;
  83     procedure SetEnableVSync(aValue: Boolean);
  84     procedure LogMsg(const aSeverity: TSeverity; const aMsg: String);
  85     procedure SetDebugMode(const aEnable: Boolean);
  86   protected
  87     fUseVersion: Boolean;
  88     fPixelFormatSettings: TglcContextPixelFormatSettings;
  89     fVersionSettings: TglcContextVersionSettings;
  90     procedure OpenContext; virtual;
  91
  92   public
  93     property PixelFormatSettings: TglcContextPixelFormatSettings read fPixelFormatSettings;
  94     property VersionSettings:     TglcContextVersionSettings     read fVersionSettings;
  95
  96     constructor Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings); virtual; overload;
  97     constructor Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings; const aVersionSettings: TglcContextVersionSettings); virtual; overload;
  98     destructor Destroy; override;
  99
 100     property ThreadID:    TThreadID read fThreadID;
 101     property EnableVSync: Boolean   read GetEnableVSync write SetEnableVSync;
 102
 103     procedure BuildContext;
 104     procedure EnableDebugOutput(const aLogEvent: TLogEvent);
 105     procedure DisableDebugOutput;
 106     procedure CloseContext; virtual;
 107     procedure Activate; virtual; abstract;
 108     procedure Deactivate; virtual; abstract;
 109     function IsActive: boolean; virtual; abstract;
 110     procedure SwapBuffers; virtual; abstract;
 111     procedure SetSwapInterval(const aInterval: GLint); virtual; abstract;
 112     function GetSwapInterval: GLint; virtual; abstract;
 113     procedure Share(const aContext: TglcContext); virtual; abstract;
 114
 115   private class var
 116     fMainContextThreadID: TThreadID;
 117   public
 118     class property MainContextThreadID: TThreadID read fMainContextThreadID;
 119     class function MakePF(DoubleBuffered: boolean = true;
 120                           Stereo: boolean=false;
 121                           MultiSampling: TMultiSample=1;
 122                           ColorBits: Integer=32;
 123                           DepthBits: Integer=24;
 124                           StencilBits: Integer=0;
 125                           AccumBits: Integer=0;
 126                           AuxBuffers: Integer=0;
 127                           Layer: Integer=0): TglcContextPixelFormatSettings;
 128     class function MakeVersion(const aMajor, aMinor: Integer; const aForwardCompatible: Boolean): TglcContextVersionSettings;
 129     class function GetPlatformClass: TglcContextClass;
 130     class function ChangeDisplaySettings(const aWidth, aHeight,
 131       aBitPerPixel, aFreq: Integer; const aFlags: TglcDisplayFlags): Boolean; virtual; abstract;
 132     class function IsAnyContextActive: boolean; virtual;
 133   end;
 134
 135 implementation
 136
 137 uses
 138   {$IFDEF WINDOWS}
 139     uglcContextWGL
 140   {$ENDIF}
 141   {$IFDEF LINUX}
 142     uglcContextGtk2GLX
 143   {$ENDIF}
 144   ;
 145
 146 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}
 147 var
 148   src, typ: String;
 149   sv: TSeverity;
 150 begin
 151   case source of
 152     GL_DEBUG_SOURCE_API_ARB            : src:= 'API';
 153     GL_DEBUG_SOURCE_WINDOW_SYSTEM_ARB  : src:= 'WINDOW';
 154     GL_DEBUG_SOURCE_SHADER_COMPILER_ARB: src:= 'SHADER';
 155     GL_DEBUG_SOURCE_THIRD_PARTY_ARB    : src:= '3RDPARTY';
 156     GL_DEBUG_SOURCE_APPLICATION_ARB    : src:= 'APPLICATION';
 157     GL_DEBUG_SOURCE_OTHER_ARB          : src:= 'OTHER';
 158   end;
 159   src:= 'GL_' + src;
 160
 161   case type_ of
 162     GL_DEBUG_TYPE_ERROR_ARB               : typ:= 'ERROR';
 163     GL_DEBUG_TYPE_DEPRECATED_BEHAVIOR_ARB : typ:= 'DEPRECATED';
 164     GL_DEBUG_TYPE_UNDEFINED_BEHAVIOR_ARB  : typ:= 'UNDEF BEHAV';
 165     GL_DEBUG_TYPE_PORTABILITY_ARB         : typ:= 'PORTABILITY';
 166     GL_DEBUG_TYPE_PERFORMANCE_ARB         : typ:= 'PERFORMANCE';
 167     GL_DEBUG_TYPE_OTHER_ARB               : typ:= 'OTHER';
 168   end;
 169
 170   case severity of
 171     GL_DEBUG_SEVERITY_LOW_ARB:    sv := svLow;
 172     GL_DEBUG_SEVERITY_MEDIUM_ARB: sv := svMedium;
 173     GL_DEBUG_SEVERITY_HIGH_ARB:   sv := svHigh;
 174   end;
 175
 176   TglcContext(userParam).LogMsg(sv, format('%s [%d] %s',[typ, id, message_]));
 177 end;
 178
 179 procedure GlDebugCallbackAMD(id: GLuint; category: GLenum; severity: GLenum; {%H-}length: GLsizei; const message_: PGLchar; {%H-}userParam: PGLvoid); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF}
 180 var
 181   src: String;
 182   sv: TSeverity;
 183 begin
 184   case category of
 185     GL_DEBUG_CATEGORY_API_ERROR_AMD            : src:= 'API';
 186     GL_DEBUG_CATEGORY_WINDOW_SYSTEM_AMD        : src:= 'WINDOW';
 187     GL_DEBUG_CATEGORY_DEPRECATION_AMD          : src:= 'SHADER';
 188     GL_DEBUG_CATEGORY_UNDEFINED_BEHAVIOR_AMD   : src:= 'UNDEF BEHAV';
 189     GL_DEBUG_CATEGORY_PERFORMANCE_AMD          : src:= 'PERFORMANCE';
 190     GL_DEBUG_CATEGORY_SHADER_COMPILER_AMD      : src:= 'SHADER';
 191     GL_DEBUG_CATEGORY_APPLICATION_AMD          : src:= 'APPLICATION';
 192     GL_DEBUG_CATEGORY_OTHER_AMD                : src:= 'OTHER';
 193   end;
 194   src:= 'GL_' + src;
 195
 196   case severity of
 197     GL_DEBUG_SEVERITY_LOW_AMD:    sv := svLow;
 198     GL_DEBUG_SEVERITY_MEDIUM_AMD: sv := svMedium;
 199     GL_DEBUG_SEVERITY_HIGH_AMD:   sv := svHigh;
 200   end;
 201
 202   TglcContext(userParam).LogMsg(sv, format('[%d] %s',[id, message_]));
 203 end;
 204
 205 function TglcContext.GetEnableVSync: Boolean;
 206 begin
 207   result := fEnableVsync;
 208 end;
 209
 210 procedure TglcContext.SetEnableVSync(aValue: Boolean);
 211 begin
 212   fEnableVsync := aValue;
 213   if IsActive then begin
 214     if fEnableVsync then
 215       SetSwapInterval(1)
 216     else
 217       SetSwapInterval(0);
 218   end;
 219 end;
 220
 221 procedure TglcContext.LogMsg(const aSeverity: TSeverity; const aMsg: String);
 222 begin
 223   if Assigned(fLogEvent) then
 224     fLogEvent(self, aSeverity, aMsg);
 225 end;
 226
 227 procedure TglcContext.SetDebugMode(const aEnable: Boolean);
 228 begin
 229   // ARB Debug Output
 230   if GL_ARB_debug_output then begin
 231     glDebugMessageCallbackARB(@GlDebugCallbackARB, self);
 232     glDebugMessageControlARB(GL_DONT_CARE, GL_DONT_CARE, GL_DONT_CARE, 0, nil, aEnable);
 233     if aEnable then begin
 234       glEnable(GL_DEBUG_OUTPUT_SYNCHRONOUS_ARB);
 235       glDebugMessageInsertARB(GL_DEBUG_SOURCE_APPLICATION_ARB, GL_DEBUG_TYPE_OTHER_ARB, 0, GL_DEBUG_SEVERITY_LOW_ARB, -1, PGLchar('Attached ARB_debug_output'));
 236     end;
 237
 238   // AMD Debug Output
 239   end else if GL_AMD_debug_output then begin
 240     glDebugMessageCallbackAMD(@GlDebugCallbackAMD, self);
 241     glDebugMessageEnableAMD(GL_DONT_CARE, GL_DONT_CARE, 0, nil, aEnable);
 242     if aEnable then
 243       glDebugMessageInsertAMD(GL_DEBUG_CATEGORY_OTHER_AMD, GL_DEBUG_SEVERITY_LOW_ARB, 0, -1, PGLchar('Attached ARB_debug_output'));
 244   end;
 245 end;
 246
 247 procedure TglcContext.OpenContext;
 248 begin
 249   fThreadID := GetCurrentThreadId;
 250   if fMainContextThreadID = 0 then
 251     fMainContextThreadID := fThreadID;
 252 end;
 253
 254 class function TglcContext.MakePF(DoubleBuffered: boolean; Stereo: boolean; MultiSampling: TMultiSample; ColorBits: Integer;
 255   DepthBits: Integer; StencilBits: Integer; AccumBits: Integer; AuxBuffers: Integer; Layer: Integer): TglcContextPixelFormatSettings;
 256 begin
 257   Result.DoubleBuffered:= DoubleBuffered;
 258   Result.Stereo:= Stereo;
 259   Result.MultiSampling:= MultiSampling;
 260   Result.ColorBits:= ColorBits;
 261   Result.DepthBits:= DepthBits;
 262   Result.StencilBits:= StencilBits;
 263   Result.AccumBits:= AccumBits;
 264   Result.AuxBuffers:= AuxBuffers;
 265   Result.Layer:= Layer;
 266 end;
 267
 268 class function TglcContext.MakeVersion(const aMajor, aMinor: Integer; const aForwardCompatible: Boolean): TglcContextVersionSettings;
 269 begin
 270   result.Major := aMajor;
 271   result.Minor := aMinor;
 272   result.ForwardCompatible := aForwardCompatible;
 273 end;
 274
 275 class function TglcContext.GetPlatformClass: TglcContextClass;
 276 begin
 277   {$IFDEF WINDOWS}
 278   Result:= TglcContextWGL;
 279   {$ENDIF}
 280   {$IFDEF LINUX}
 281   Result:= TglcContextGtk2GLX;
 282   {$ENDIF}
 283 end;
 284
 285 class function TglcContext.IsAnyContextActive: boolean;
 286 begin
 287   Result:= GetPlatformClass.IsAnyContextActive;
 288 end;
 289
 290 constructor TglcContext.Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings);
 291 begin
 292   inherited Create;
 293   fPixelFormatSettings := aPixelFormatSettings;
 294   FControl             := aControl;
 295   fThreadID            := 0;
 296   fEnableVsync         := false;
 297   fUseVersion          := false;
 298   InitOpenGL();
 299 end;
 300
 301 constructor TglcContext.Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings; const aVersionSettings: TglcContextVersionSettings);
 302 begin
 303   Create(aControl, aPixelFormatSettings);
 304   fVersionSettings := aVersionSettings;
 305   fUseVersion      := true;
 306 end;
 307
 308 destructor TglcContext.Destroy;
 309 begin
 310   if (GetCurrentThreadId = fMainContextThreadID) then
 311     fMainContextThreadID := 0;
 312   CloseContext;
 313   inherited Destroy;
 314 end;
 315
 316 procedure TglcContext.BuildContext;
 317 begin
 318   OpenContext;
 319   Activate;
 320   ReadImplementationProperties;
 321   ReadExtensions;
 322   SetEnableVSync(fEnableVsync);
 323 end;
 324
 325 procedure TglcContext.EnableDebugOutput(const aLogEvent: TLogEvent);
 326 begin
 327   fLogEvent := aLogEvent;
 328   SetDebugMode(true);
 329 end;
 330
 331 procedure TglcContext.DisableDebugOutput;
 332 begin
 333   SetDebugMode(false);
 334 end;
 335
 336 procedure TglcContext.CloseContext;
 337 begin
 338   if fMainContextThreadID = fThreadID then
 339     fMainContextThreadID := 0;
 340 end;
 341
 342 initialization
 343   TglcContext.fMainContextThreadID := 0;
 344
 345 end.
 346