uglcContextWGL.pas

   1 unit uglcContextWGL;
   2
   3 { Package:      OpenGLCore
   4   Prefix:       glc - OpenGL Core
   5   Beschreibung: diese Unit enthält eine Klassen-Kapselung für OpenGL Kontexte für Windows
   6   Hint:         diese Unit sollte niemals direkt genutzt werden (siehe uglcContext) }
   7
   8 interface
   9
  10 uses
  11   Classes, SysUtils, Forms, Windows, uglcContext, dglOpenGL, Controls;
  12
  13 type
  14   EWGLError = class(EGLError);
  15
  16   { TglcContextWGL }
  17
  18   TglcContextWGL = class(TglcContext)
  19   private
  20     FDC: HDC;
  21     FRC: HGLRC;
  22     fHandle: THandle;
  23     fPixelFormat: Integer;
  24     {%H-}constructor Create(const aControl: TWinControl);
  25   protected
  26     procedure UpdatePixelFormat;
  27     procedure OpenContext; override;
  28     function FindPixelFormat: Integer;
  29     function FindPixelFormatNoAA: Integer;
  30     procedure OpenFromPF(PixelFormat: Integer);
  31   public
  32     constructor Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings); override; overload;
  33     constructor Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings; const aVersionSettings: TglcContextVersionSettings); override; overload;
  34
  35     procedure CloseContext; override;
  36     procedure Activate; override;
  37     procedure Deactivate; override;
  38     function IsActive: boolean; override;
  39     procedure SwapBuffers; override;
  40     procedure SetSwapInterval(const aInterval: GLint); override;
  41     function GetSwapInterval: GLint; override;
  42     procedure Share(const aContext: TglcContext); override;
  43
  44     class function ChangeDisplaySettings(const aWidth, aHeight, aBitPerPixel, aFreq: Integer;
  45       const aFlags: TglcDisplayFlags): Boolean; override;
  46     class function IsAnyContextActive: boolean; override;
  47   end;
  48
  49 implementation
  50
  51 { TglcContextWGL }
  52
  53 constructor TglcContextWGL.Create(const aControl: TWinControl);
  54 begin
  55   inherited Create(aControl, MakePF());
  56   fHandle := aControl.Handle;
  57 end;
  58
  59 procedure TglcContextWGL.UpdatePixelFormat;
  60 begin
  61   fPixelFormat := FindPixelFormat;
  62   if (fPixelFormat = 0) then begin
  63     // try without MS
  64     fPixelFormatSettings.MultiSampling := 1;
  65     fPixelFormat := FindPixelFormat;
  66   end;
  67 end;
  68
  69 procedure TglcContextWGL.OpenContext;
  70 begin
  71   inherited OpenContext;
  72   OpenFromPF(fPixelFormat);
  73 end;
  74
  75 function TglcContextWGL.FindPixelFormat: Integer;
  76 var
  77   OldRC: HGLRC; OldDC: HDC;
  78   tmpWnd: TForm;
  79   tmpContext: TglcContextWGL;
  80   pf, i, max: integer;
  81   Count: GLuint;
  82   PFList, SampleList: array[0..31] of GLint;
  83
  84   procedure ChoosePF(pPFList, pSampleList: PGLint; MaxCount: integer);
  85   var
  86     //ARB_Erweiterung vorhanden
  87     //|          EXT_Erweiterung vorhanden
  88     MultiARBSup, MultiEXTSup: Boolean;
  89     //Liste der Integer Attribute
  90     IAttrib: array[0..22] of GLint;
  91     //Liste der Float Attribute (nur 0, da kein Wert)
  92     FAttrib: GLFloat;
  93     QueryAtrib, i: Integer;
  94     PPosiblePF, PSample: PglInt;
  95   begin
  96     //Pixelformate mit AA auslesen
  97     MultiARBSup := false;
  98     MultiEXTSup := false;
  99     if WGL_ARB_extensions_string and
 100        WGL_ARB_pixel_format and
 101        (WGL_ARB_MULTISAMPLE or GL_ARB_MULTISAMPLE) then
 102       multiARBSup := true;
 103     if WGL_EXT_extensions_string and
 104        WGL_EXT_pixel_format and
 105        (WGL_EXT_MULTISAMPLE or GL_EXT_MULTISAMPLE) then
 106       multiEXTSup := true;
 107
 108     if multiARBSup then
 109       Read_WGL_ARB_pixel_format
 110     else if multiEXTSup then
 111       Read_WGL_EXT_pixel_format;
 112
 113     if not (MultiARBSup or MultiEXTSup) then
 114       exit;
 115
 116     IAttrib[00] := WGL_DRAW_TO_WINDOW_ARB;
 117     IAttrib[01] := 1;
 118
 119     IAttrib[02] := WGL_SUPPORT_OPENGL_ARB;
 120     IAttrib[03] := 1;
 121
 122     IAttrib[04] := WGL_DOUBLE_BUFFER_ARB;
 123     if (fPixelFormatSettings.DoubleBuffered) then
 124       IAttrib[05] := 1
 125     else
 126       IAttrib[05] := 0;
 127
 128     IAttrib[06] := WGL_PIXEL_TYPE_ARB;
 129     IAttrib[07] := WGL_TYPE_RGBA_ARB;
 130
 131     IAttrib[08] := WGL_COLOR_BITS_ARB;
 132     IAttrib[09] := fPixelFormatSettings.ColorBits;
 133
 134     IAttrib[10] := WGL_ALPHA_BITS_ARB;
 135     IAttrib[11] := 0; //TODO: fPixelFormatSettings.AlphaBits;
 136
 137     IAttrib[12] := WGL_DEPTH_BITS_ARB;
 138     IAttrib[13] := fPixelFormatSettings.DepthBits;
 139
 140     IAttrib[14] := WGL_STENCIL_BITS_ARB;
 141     IAttrib[15] := fPixelFormatSettings.StencilBits;
 142
 143     IAttrib[16] := WGL_ACCUM_BITS_ARB;
 144     IAttrib[17] := fPixelFormatSettings.AccumBits;
 145
 146     IAttrib[18] := WGL_AUX_BUFFERS_ARB;
 147     IAttrib[19] := fPixelFormatSettings.AuxBuffers;
 148
 149     IAttrib[20] := WGL_SAMPLE_BUFFERS_ARB;
 150     IAttrib[21] := 1;
 151
 152     IAttrib[22] := 0;
 153     FAttrib     := 0;
 154
 155     if multiARBSup then
 156       wglChoosePixelFormatARB(tmpContext.FDC, @IAttrib[0], @FAttrib, MaxCount, pPFList, @Count)
 157     else if multiEXTSup then
 158       wglChoosePixelFormatEXT(tmpContext.FDC, @IAttrib[0], @FAttrib, MaxCount, pPFList, @Count);
 159
 160     if Count > length(PFList) then
 161       Count := length(PFList);
 162
 163     QueryAtrib := WGL_SAMPLES_ARB;
 164     PSample    := pSampleList;
 165     PPosiblePF := @PFList[0];
 166     for i := 0 to Count-1 do begin
 167       if multiARBSup then
 168         wglGetPixelFormatAttribivARB(tmpContext.FDC, PPosiblePF^, 0, 1, @QueryAtrib, PSample)
 169       else if multiEXTSup then
 170         wglGetPixelFormatAttribivEXT(tmpContext.FDC, PPosiblePF^, 0, 1, @QueryAtrib, PSample);
 171       inc(PSample);
 172       inc(PPosiblePF);
 173     end;
 174   end;
 175 begin
 176   if (fPixelFormatSettings.MultiSampling = 1) then begin
 177     Result := FindPixelFormatNoAA;
 178     exit;
 179   end;
 180   Result := 0;
 181   OldDC  := wglGetCurrentDC();
 182   OldRC  := wglGetCurrentContext();
 183   try
 184     tmpWnd     := TForm.Create(nil);
 185     tmpContext := TglcContextWGL.Create(tmpWnd);
 186     try
 187       pf := tmpContext.FindPixelFormatNoAA;
 188       tmpContext.OpenFromPF(pf);
 189       tmpContext.Activate;
 190
 191       FillChar({%H-}PFList[0], Length(PFList), 0);
 192       FillChar({%H-}SampleList[0], Length(SampleList), 0);
 193       ChoosePF(@PFList[0], @SampleList[0], length(SampleList));
 194       max := 0;
 195       for i := 0 to Count-1 do begin
 196         if (max < SampleList[i]) and (SampleList[i] <= fPixelFormatSettings.MultiSampling) and (PFList[i] <> 0) then begin
 197           max := SampleList[i];
 198           result := PFList[i];
 199           if (max = fPixelFormatSettings.MultiSampling) then
 200             break;
 201         end;
 202       end;
 203       tmpContext.Deactivate;
 204     finally
 205       FreeAndNil(tmpContext);
 206       FreeAndNil(tmpWnd);
 207     end;
 208   finally
 209     if (OldDC <> 0) and (OldRC <> 0) then
 210      ActivateRenderingContext(OldDC, OldRC);
 211   end;
 212 end;
 213
 214 function TglcContextWGL.FindPixelFormatNoAA: Integer;
 215 const
 216   MemoryDCs = [OBJ_MEMDC, OBJ_METADC, OBJ_ENHMETADC];
 217 var
 218   //DeviceContext
 219   DC: HDC;
 220   //Objekttyp des DCs
 221   AType: DWord;
 222   //Beschreibung zum passenden Pixelformat
 223   PFDescriptor: TPixelFormatDescriptor;
 224 begin
 225   result := 0;
 226   DC := GetDC(fHandle);
 227   if DC = 0 then begin
 228     exit;
 229   end;
 230   FillChar(PFDescriptor{%H-}, SizeOf(PFDescriptor), #0);
 231   with PFDescriptor do begin
 232     nSize    := SizeOf(PFDescriptor);
 233     nVersion := 1;
 234     dwFlags  := PFD_SUPPORT_OPENGL;
 235     AType    := GetObjectType(DC);
 236     if AType = 0 then begin
 237       exit;
 238     end;
 239     if fPixelFormatSettings.DoubleBuffered then
 240       dwFlags := dwFlags or PFD_DOUBLEBUFFER;
 241     if fPixelFormatSettings.Stereo then
 242       dwFlags := dwFlags or PFD_STEREO;
 243     if AType in MemoryDCs then
 244       dwFlags := dwFlags or PFD_DRAW_TO_BITMAP
 245     else
 246       dwFlags := dwFlags or PFD_DRAW_TO_WINDOW;
 247
 248     iPixelType   := PFD_TYPE_RGBA;
 249     cColorBits   := fPixelFormatSettings.ColorBits;
 250 //TODO:    cAlphaBits   := fPixelFormatSettings.AlphaBits;
 251     cDepthBits   := fPixelFormatSettings.DepthBits;
 252     cStencilBits := fPixelFormatSettings.StencilBits;
 253     cAccumBits   := fPixelFormatSettings.AccumBits;
 254     cAuxBuffers  := fPixelFormatSettings.AuxBuffers;
 255
 256     if fPixelFormatSettings.Layer = 0 then
 257       iLayerType := PFD_MAIN_PLANE
 258     else if fPixelFormatSettings.Layer > 0 then
 259       iLayerType := PFD_OVERLAY_PLANE
 260     else
 261       iLayerType := Byte(PFD_UNDERLAY_PLANE);
 262   end;
 263   result := ChoosePixelFormat(DC, @PFDescriptor);
 264 end;
 265
 266 procedure TglcContextWGL.OpenFromPF(PixelFormat: Integer);
 267 var
 268   tmpRC: HGLRC;
 269   Attribs: array of GLint;
 270   CreateContextAttribs: TwglCreateContextAttribsARB;
 271 begin
 272   if PixelFormat = 0 then begin
 273     raise EWGLError.Create('Invalid PixelFormat');
 274   end;
 275
 276   FDC := GetDC(fHandle);
 277   if FDC = 0 then begin
 278     raise EWGLError.CreateFmt('Cannot create DC on %x',[fHandle]);
 279   end;
 280
 281   if not SetPixelFormat(FDC, PixelFormat, nil) then begin
 282     ReleaseDC(fHandle, FDC);
 283     raise EWGLError.CreateFmt('Cannot set PF %d on Control %x DC %d',[PixelFormat, fHandle, FDC]);
 284   end;
 285
 286   tmpRC := wglCreateContext(FDC);
 287   if tmpRC = 0 then begin
 288     ReleaseDC(fHandle, FDC);
 289     raise EWGLError.CreateFmt('Cannot create context on Control %x DC %d',[PixelFormat, fHandle, FDC]);
 290   end;
 291
 292   if fUseVersion and
 293      (fVersionSettings.Major <> GLC_CONTEXT_VERSION_UNKNOWN) and
 294      (fVersionSettings.Minor <> GLC_CONTEXT_VERSION_UNKNOWN) then
 295   begin
 296     { Code from dglOpenGL.pas (modified) }
 297     wglMakeCurrent(FDC, tmpRC);
 298
 299     // Set attributes to describe our requested context
 300     SetLength(Attribs, 5);
 301     Attribs[0] := WGL_CONTEXT_MAJOR_VERSION_ARB;
 302     Attribs[1] := fVersionSettings.Major;
 303     Attribs[2] := WGL_CONTEXT_MINOR_VERSION_ARB;
 304     Attribs[3] := fVersionSettings.Minor;
 305
 306     // Add context flag for forward compatible context
 307     // Forward compatible means no more support for legacy functions like
 308     // immediate mode (glvertex, glrotate, gltranslate, etc.)
 309     if fVersionSettings.ForwardCompatible then begin
 310       SetLength(Attribs, Length(Attribs)+2);
 311       Attribs[4] := WGL_CONTEXT_FLAGS_ARB;
 312       Attribs[5] := WGL_CONTEXT_FORWARD_COMPATIBLE_BIT_ARB;
 313     end;
 314
 315     // Attribute flags must be finalized with a zero
 316     Attribs[High(Attribs)] := 0;
 317
 318     // Get function pointer for new context creation function
 319     CreateContextAttribs := TwglCreateContextAttribsARB(wglGetProcAddress('wglCreateContextAttribsARB'));
 320     if not Assigned(CreateContextAttribs) then begin
 321       wglMakeCurrent(0, 0);
 322       wglDeleteContext(tmpRC);
 323       ReleaseDC(fHandle, FDC);
 324       raise Exception.Create('Could not get function pointer adress for wglCreateContextAttribsARB - OpenGL 3.x and above not supported!');
 325     end;
 326
 327     // Create context
 328     FRC := CreateContextAttribs(FDC, 0, @Attribs[0]);
 329     if (FRC = 0) then begin
 330       wglMakeCurrent(0, 0);
 331       wglDeleteContext(tmpRC);
 332       ReleaseDC(fHandle, FDC);
 333       raise Exception.Create('Could not create the desired OpenGL rendering context!');
 334     end;
 335
 336     wglMakeCurrent(0, 0);
 337     wglDeleteContext(tmpRC);
 338   end else
 339     FRC := tmpRC;
 340 end;
 341
 342 constructor TglcContextWGL.Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings);
 343 begin
 344   inherited Create(aControl, aPixelFormatSettings);
 345   fHandle := aControl.Handle;
 346   UpdatePixelFormat;
 347 end;
 348
 349 constructor TglcContextWGL.Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings; const aVersionSettings: TglcContextVersionSettings);
 350 begin
 351   inherited Create(aControl, aPixelFormatSettings, aVersionSettings);
 352   fHandle := aControl.Handle;
 353   UpdatePixelFormat;
 354 end;
 355
 356 procedure TglcContextWGL.CloseContext;
 357 begin
 358   if (FRC <> 0) then begin
 359     Deactivate;
 360     DestroyRenderingContext(FRC);
 361     ReleaseDC(fHandle, FDC);
 362     FRC := 0;
 363     FDC := 0;
 364   end;
 365 end;
 366
 367 procedure TglcContextWGL.Activate;
 368 begin
 369   ActivateRenderingContext(FDC, FRC);
 370 end;
 371
 372 procedure TglcContextWGL.Deactivate;
 373 begin
 374   if wglGetCurrentContext()=FRC then
 375     DeactivateRenderingContext;
 376 end;
 377
 378 function TglcContextWGL.IsActive: boolean;
 379 begin
 380   Result:= (FRC <> 0) and
 381            (FRC = wglGetCurrentContext()) and
 382            (FDC = wglGetCurrentDC());
 383 end;
 384
 385 procedure TglcContextWGL.SwapBuffers;
 386 begin
 387   Windows.SwapBuffers(FDC);
 388 end;
 389
 390 procedure TglcContextWGL.SetSwapInterval(const aInterval: GLint);
 391 begin
 392   wglSwapIntervalEXT(aInterval);
 393 end;
 394
 395 function TglcContextWGL.GetSwapInterval: GLint;
 396 begin
 397   result := wglGetSwapIntervalEXT();
 398 end;
 399
 400 procedure TglcContextWGL.Share(const aContext: TglcContext);
 401 begin
 402   wglShareLists(FRC, (aContext as TglcContextWGL).FRC);
 403 end;
 404
 405 class function TglcContextWGL.ChangeDisplaySettings(const aWidth, aHeight,
 406   aBitPerPixel, aFreq: Integer; const aFlags: TglcDisplayFlags): Boolean;
 407 var
 408   dm: TDeviceMode;
 409   flags: Cardinal;
 410 begin
 411   FillChar(dm{%H-}, SizeOf(dm), 0);
 412   with dm do begin
 413     dmSize             := SizeOf(dm);
 414     dmPelsWidth        := aWidth;
 415     dmPelsHeight       := aHeight;
 416     dmDisplayFrequency := aFreq;
 417     dmBitsPerPel       := aBitPerPixel;
 418     dmFields           := DM_PELSWIDTH or DM_PELSHEIGHT or DM_BITSPERPEL or DM_DISPLAYFREQUENCY;
 419   end;
 420   flags := 0; //CDS_TEST;
 421   if (dfFullscreen in aFlags) then
 422     flags := flags or CDS_FULLSCREEN;
 423   result := (Windows.ChangeDisplaySettings(dm, flags) = DISP_CHANGE_SUCCESSFUL);
 424 end;
 425
 426 class function TglcContextWGL.IsAnyContextActive: boolean;
 427 begin
 428   Result:= (wglGetCurrentContext()<>0) and (wglGetCurrentDC()<>0);
 429 end;
 430
 431 end.
 432