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
  65   TglcDisplayFlag = (
  66     dfFullscreen);
  67   TglcDisplayFlags = set of TglcDisplayFlag;
  68
  69   EGLError = class(Exception);
  70
  71   { TglcContext }
  72   TglcContextClass = class of TglcContext;
  73   TglcContext = class
  74   private
  75     fControl: TWinControl;
  76     fThreadID: TThreadID;
  77     fEnableVsync: Boolean;
  78
  79     function GetEnableVSync: Boolean;
  80     procedure SetEnableVSync(aValue: Boolean);
  81
  82   protected
  83     fUseVersion: Boolean;
  84     fPixelFormatSettings: TglcContextPixelFormatSettings;
  85     fVersionSettings: TglcContextVersionSettings;
  86     procedure OpenContext; virtual;
  87
  88   public
  89     property PixelFormatSettings: TglcContextPixelFormatSettings read fPixelFormatSettings;
  90     property VersionSettings:     TglcContextVersionSettings     read fVersionSettings;
  91
  92     constructor Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings); virtual; overload;
  93     constructor Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings; const aVersionSettings: TglcContextVersionSettings); virtual; overload;
  94     destructor Destroy; override;
  95
  96     property ThreadID:    TThreadID read fThreadID;
  97     property EnableVSync: Boolean   read GetEnableVSync write SetEnableVSync;
  98
  99     procedure BuildContext;
 100     procedure CloseContext; virtual;
 101     procedure Activate; virtual; abstract;
 102     procedure Deactivate; virtual; abstract;
 103     function IsActive: boolean; virtual; abstract;
 104     procedure SwapBuffers; virtual; abstract;
 105     procedure SetSwapInterval(const aInterval: GLint); virtual; abstract;
 106     function GetSwapInterval: GLint; virtual; abstract;
 107     procedure Share(const aContext: TglcContext); virtual; abstract;
 108
 109   private class var
 110     fMainContextThreadID: TThreadID;
 111   public
 112     class property MainContextThreadID: TThreadID read fMainContextThreadID;
 113     class function MakePF(DoubleBuffered: boolean = true;
 114                           Stereo: boolean=false;
 115                           MultiSampling: TMultiSample=1;
 116                           ColorBits: Integer=32;
 117                           DepthBits: Integer=24;
 118                           StencilBits: Integer=0;
 119                           AccumBits: Integer=0;
 120                           AuxBuffers: Integer=0;
 121                           Layer: Integer=0): TglcContextPixelFormatSettings;
 122     class function MakeVersion(const aMajor, aMinor: Integer; const aForwardCompatible: Boolean): TglcContextVersionSettings;
 123     class function GetPlatformClass: TglcContextClass;
 124     class function ChangeDisplaySettings(const aWidth, aHeight,
 125       aBitPerPixel, aFreq: Integer; const aFlags: TglcDisplayFlags): Boolean; virtual; abstract;
 126     class function IsAnyContextActive: boolean; virtual;
 127   end;
 128
 129 implementation
 130
 131 uses
 132   {$IFDEF WINDOWS}
 133     uglcContextWGL
 134   {$ENDIF}
 135   {$IFDEF LINUX}
 136     uglcContextGtk2GLX
 137   {$ENDIF}
 138   ;
 139
 140 function TglcContext.GetEnableVSync: Boolean;
 141 begin
 142   result := fEnableVsync;
 143 end;
 144
 145 procedure TglcContext.SetEnableVSync(aValue: Boolean);
 146 begin
 147   fEnableVsync := aValue;
 148   if IsActive then begin
 149     if fEnableVsync then
 150       SetSwapInterval(1)
 151     else
 152       SetSwapInterval(0);
 153   end;
 154 end;
 155
 156 procedure TglcContext.OpenContext;
 157 begin
 158   fThreadID := GetCurrentThreadId;
 159   if fMainContextThreadID = 0 then
 160     fMainContextThreadID := fThreadID;
 161 end;
 162
 163 class function TglcContext.MakePF(DoubleBuffered: boolean; Stereo: boolean; MultiSampling: TMultiSample; ColorBits: Integer;
 164   DepthBits: Integer; StencilBits: Integer; AccumBits: Integer; AuxBuffers: Integer; Layer: Integer): TglcContextPixelFormatSettings;
 165 begin
 166   Result.DoubleBuffered:= DoubleBuffered;
 167   Result.Stereo:= Stereo;
 168   Result.MultiSampling:= MultiSampling;
 169   Result.ColorBits:= ColorBits;
 170   Result.DepthBits:= DepthBits;
 171   Result.StencilBits:= StencilBits;
 172   Result.AccumBits:= AccumBits;
 173   Result.AuxBuffers:= AuxBuffers;
 174   Result.Layer:= Layer;
 175 end;
 176
 177 class function TglcContext.MakeVersion(const aMajor, aMinor: Integer; const aForwardCompatible: Boolean): TglcContextVersionSettings;
 178 begin
 179   result.Major := aMajor;
 180   result.Minor := aMinor;
 181   result.ForwardCompatible := aForwardCompatible;
 182 end;
 183
 184 class function TglcContext.GetPlatformClass: TglcContextClass;
 185 begin
 186   {$IFDEF WINDOWS}
 187   Result:= TglcContextWGL;
 188   {$ENDIF}
 189   {$IFDEF LINUX}
 190   Result:= TglcContextGtk2GLX;
 191   {$ENDIF}
 192 end;
 193
 194 class function TglcContext.IsAnyContextActive: boolean;
 195 begin
 196   Result:= GetPlatformClass.IsAnyContextActive;
 197 end;
 198
 199 constructor TglcContext.Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings);
 200 begin
 201   inherited Create;
 202   fPixelFormatSettings := aPixelFormatSettings;
 203   FControl             := aControl;
 204   fThreadID            := 0;
 205   fEnableVsync         := false;
 206   fUseVersion          := false;
 207   InitOpenGL();
 208 end;
 209
 210 constructor TglcContext.Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings; const aVersionSettings: TglcContextVersionSettings);
 211 begin
 212   Create(aControl, aPixelFormatSettings);
 213   fVersionSettings := aVersionSettings;
 214   fUseVersion      := true;
 215 end;
 216
 217 destructor TglcContext.Destroy;
 218 begin
 219   if (GetCurrentThreadId = fMainContextThreadID) then
 220     fMainContextThreadID := 0;
 221   CloseContext;
 222   inherited Destroy;
 223 end;
 224
 225 procedure TglcContext.BuildContext;
 226 begin
 227   OpenContext;
 228   Activate;
 229   ReadImplementationProperties;
 230   ReadExtensions;
 231   SetEnableVSync(fEnableVsync);
 232 end;
 233
 234 procedure TglcContext.CloseContext;
 235 begin
 236   if fMainContextThreadID = fThreadID then
 237     fMainContextThreadID := 0;
 238 end;
 239
 240 initialization
 241   TglcContext.fMainContextThreadID := 0;
 242
 243 end.
 244