mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-05 17:17:52 +02:00
79c9bba8b6
Some changes over the years broke Gtk1 compatibility with the TOpenGLControl control. This change fixes the code so that it compiles and works under Gtk1.
774 lines
23 KiB
ObjectPascal
774 lines
23 KiB
ObjectPascal
{
|
|
*****************************************************************************
|
|
See the file COPYING.modifiedLGPL.txt, included in this distribution,
|
|
for details about the license.
|
|
*****************************************************************************
|
|
|
|
Author: Mattias Gaertner
|
|
|
|
Abstract:
|
|
TOpenGLControl is a LCL control with an opengl context.
|
|
It works under the following platforms:
|
|
- gtk with glx : full
|
|
- gtk2 with glx : full
|
|
- carbon with agl : full
|
|
- cocoa : no
|
|
- windows with wgl: full
|
|
- wince : no
|
|
- qt with glx : no (started)
|
|
- fpgui with glx : no
|
|
- nogui : no
|
|
}
|
|
unit OpenGLContext;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
// choose the right backend depending on used LCL widgetset
|
|
{$IFDEF LCLGTK}
|
|
{$IFDEF Linux}
|
|
{$DEFINE UseGtkGLX}
|
|
{$DEFINE HasRGBA}
|
|
{$DEFINE HasRGBBits}
|
|
{$DEFINE HasDebugContext}
|
|
{$DEFINE OpenGLTargetDefined}
|
|
{$DEFINE UsesModernGL}
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
{$IFDEF LCLGTK2}
|
|
{$IF defined(Linux) or defined(FreeBSD)}
|
|
{$DEFINE UseGtk2GLX}
|
|
{$DEFINE UsesModernGL}
|
|
{$DEFINE HasRGBA}
|
|
{$DEFINE HasRGBBits}
|
|
{$DEFINE HasDebugContext}
|
|
{$DEFINE OpenGLTargetDefined}
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
{$IFDEF LCLGTK3}
|
|
{$IF defined(Linux) or defined(FreeBSD)}
|
|
{$DEFINE UseGtk3GLX}
|
|
{$DEFINE UsesModernGL}
|
|
{$DEFINE HasRGBA}
|
|
{$DEFINE HasRGBBits}
|
|
{$DEFINE HasDebugContext}
|
|
{$DEFINE OpenGLTargetDefined}
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
{$IFDEF LCLCarbon}
|
|
{$DEFINE UseCarbonAGL}
|
|
{$DEFINE HasRGBA}
|
|
{$DEFINE HasRGBBits}
|
|
{$DEFINE OpenGLTargetDefined}
|
|
{$ENDIF}
|
|
{$IFDEF LCLCocoa}
|
|
{$DEFINE UseCocoaNS}
|
|
{$DEFINE UsesModernGL}
|
|
{$DEFINE OpenGLTargetDefined}
|
|
{$DEFINE HasMacRetinaMode}
|
|
{$ENDIF}
|
|
{$IFDEF LCLWin32}
|
|
{$DEFINE UseWin32WGL}
|
|
{$DEFINE HasRGBA}
|
|
{$DEFINE HasRGBBits}
|
|
{$DEFINE HasDebugContext}
|
|
{$DEFINE OpenGLTargetDefined}
|
|
{$ENDIF}
|
|
{$IFDEF LCLQT}
|
|
{$DEFINE UseQTGLX}
|
|
{$DEFINE UsesModernGL}
|
|
{$DEFINE HasRGBA}
|
|
{$DEFINE HasRGBBits}
|
|
{$DEFINE OpenGLTargetDefined}
|
|
{$ENDIF}
|
|
{$IF DEFINED(LCLQT5) OR DEFINED(LCLQt6)}
|
|
{$DEFINE UseQTGLX}
|
|
{$DEFINE UsesModernGL}
|
|
{$DEFINE HasRGBA}
|
|
{$DEFINE HasRGBBits}
|
|
{$DEFINE OpenGLTargetDefined}
|
|
{$ENDIF}
|
|
{$IFNDEF OpenGLTargetDefined}
|
|
{$ERROR this LCL widgetset/OS is not yet supported}
|
|
{$ENDIF}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils,
|
|
// LCL
|
|
LCLType, LCLIntf, LResources, Forms, Controls, Graphics, LMessages,
|
|
WSLCLClasses, WSControls,
|
|
{$IFDEF UseGtkGLX}
|
|
GLGtkGlxContext;
|
|
{$ENDIF}
|
|
{$IFDEF UseGtk2GLX}
|
|
GLGtkGlxContext;
|
|
{$ENDIF}
|
|
{$IFDEF UseGtk3GLX}
|
|
GLGtk3GlxContext;
|
|
{$ENDIF}
|
|
{$IFDEF UseCarbonAGL}
|
|
GLCarbonAGLContext;
|
|
{$ENDIF}
|
|
{$IFDEF UseCocoaNS}
|
|
GLCocoaNSContext;
|
|
{$ENDIF}
|
|
{$IFDEF UseWin32WGL}
|
|
GLWin32WGLContext;
|
|
{$ENDIF}
|
|
{$IFDEF UseQTGLX}
|
|
GLQTContext;
|
|
{$ENDIF}
|
|
|
|
const
|
|
DefaultDepthBits = 24;
|
|
|
|
type
|
|
TOpenGlCtrlMakeCurrentEvent = procedure(Sender: TObject;
|
|
var Allow: boolean) of object;
|
|
|
|
TOpenGLControlOption = (ocoMacRetinaMode, ocoRenderAtDesignTime);
|
|
TOpenGLControlOptions = set of TOpenGLControlOption;
|
|
|
|
{ TCustomOpenGLControl }
|
|
{ Sharing:
|
|
You can share opengl contexts. For example:
|
|
Assume OpenGLControl2 and OpenGLControl3 should share the same as
|
|
OpenGLControl1. Then set
|
|
|
|
OpenGLControl2.SharedControl:=OpenGLControl1;
|
|
OpenGLControl3.SharedControl:=OpenGLControl1;
|
|
|
|
After this OpenGLControl1.SharingControlCount will be two and
|
|
OpenGLControl1.SharingControls will contain OpenGLControl2 and
|
|
OpenGLControl3.
|
|
}
|
|
|
|
TCustomOpenGLControl = class(TWinControl)
|
|
private
|
|
FAutoResizeViewport: boolean;
|
|
FCanvas: TCanvas; // only valid at designtime
|
|
FDebugContext: boolean;
|
|
FFrameDiffTime: integer;
|
|
FOnMakeCurrent: TOpenGlCtrlMakeCurrentEvent;
|
|
FOnPaint: TNotifyEvent;
|
|
FCurrentFrameTime: integer; // in msec
|
|
FLastFrameTime: integer; // in msec
|
|
fOpenGLMajorVersion: Cardinal;
|
|
fOpenGLMinorVersion: Cardinal;
|
|
FRGBA: boolean;
|
|
{$IFDEF HasRGBBits}
|
|
FRedBits, FGreenBits, FBlueBits,
|
|
{$ENDIF}
|
|
FMultiSampling, FAlphaBits, FDepthBits, FStencilBits, FAUXBuffers: Cardinal;
|
|
FSharedOpenGLControl: TCustomOpenGLControl;
|
|
FSharingOpenGlControls: TList;
|
|
FOptions: TOpenGLControlOptions;
|
|
function GetSharingControls(Index: integer): TCustomOpenGLControl;
|
|
procedure SetAutoResizeViewport(const AValue: boolean);
|
|
procedure SetDebugContext(AValue: boolean);
|
|
procedure SetOpenGLMajorVersion(AValue: Cardinal);
|
|
procedure SetOpenGLMinorVersion(AValue: Cardinal);
|
|
procedure SetOptions(AValue: TOpenGLControlOptions);
|
|
procedure SetRGBA(const AValue: boolean);
|
|
{$IFDEF HasRGBBits}
|
|
procedure SetRedBits(const AValue: Cardinal);
|
|
procedure SetGreenBits(const AValue: Cardinal);
|
|
procedure SetBlueBits(const AValue: Cardinal);
|
|
{$ENDIF}
|
|
procedure SetMultiSampling(const AMultiSampling: Cardinal);
|
|
procedure SetAlphaBits(const AValue: Cardinal);
|
|
procedure SetDepthBits(const AValue: Cardinal);
|
|
procedure SetStencilBits(const AValue: Cardinal);
|
|
procedure SetAUXBuffers(const AValue: Cardinal);
|
|
procedure SetSharedControl(const AValue: TCustomOpenGLControl);
|
|
function IsOpenGLRenderAllowed: boolean;
|
|
protected
|
|
class procedure WSRegisterClass; override;
|
|
procedure WMPaint(var Message: TLMPaint); message LM_PAINT;
|
|
procedure WMSize(var Message: TLMSize); message LM_SIZE;
|
|
procedure UpdateFrameTimeDiff;
|
|
procedure OpenGLAttributesChanged;
|
|
procedure CMDoubleBufferedChanged(var Message: TLMessage); message CM_DOUBLEBUFFEREDCHANGED;
|
|
public
|
|
constructor Create(TheOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
Procedure Paint; virtual;
|
|
procedure RealizeBounds; override;
|
|
procedure DoOnPaint; virtual;
|
|
procedure SwapBuffers; virtual;
|
|
function MakeCurrent(SaveOldToStack: boolean = false): boolean; virtual;
|
|
function ReleaseContext: boolean; virtual;
|
|
function RestoreOldOpenGLControl: boolean;
|
|
function SharingControlCount: integer;
|
|
property SharingControls[Index: integer]: TCustomOpenGLControl read GetSharingControls;
|
|
procedure Invalidate; override;
|
|
procedure EraseBackground(DC: HDC); override;
|
|
public
|
|
property FrameDiffTimeInMSecs: integer read FFrameDiffTime;
|
|
property OnMakeCurrent: TOpenGlCtrlMakeCurrentEvent read FOnMakeCurrent
|
|
write FOnMakeCurrent;
|
|
property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
|
|
property SharedControl: TCustomOpenGLControl read FSharedOpenGLControl
|
|
write SetSharedControl;
|
|
property AutoResizeViewport: boolean read FAutoResizeViewport
|
|
write SetAutoResizeViewport default false;
|
|
property DoubleBuffered stored True default True;
|
|
property ParentDoubleBuffered default False;
|
|
property DebugContext: boolean read FDebugContext write SetDebugContext default false; // create context with debugging enabled. Requires OpenGLMajorVersion!
|
|
property RGBA: boolean read FRGBA write SetRGBA default true;
|
|
{$IFDEF HasRGBBits}
|
|
property RedBits: Cardinal read FRedBits write SetRedBits default 8;
|
|
property GreenBits: Cardinal read FGreenBits write SetGreenBits default 8;
|
|
property BlueBits: Cardinal read FBlueBits write SetBlueBits default 8;
|
|
{$ENDIF}
|
|
property OpenGLMajorVersion: Cardinal read fOpenGLMajorVersion write SetOpenGLMajorVersion default 0;
|
|
property OpenGLMinorVersion: Cardinal read fOpenGLMinorVersion write SetOpenGLMinorVersion default 0;
|
|
{ Number of samples per pixel, for OpenGL multi-sampling (anti-aliasing).
|
|
|
|
Value <= 1 means that we use 1 sample per pixel, which means no anti-aliasing.
|
|
Higher values mean anti-aliasing. Exactly which values are supported
|
|
depends on GPU, common modern GPUs support values like 2 and 4.
|
|
|
|
If this is > 1, and we will not be able to create OpenGL
|
|
with multi-sampling, we will fallback to normal non-multi-sampled context.
|
|
You can query OpenGL values GL_SAMPLE_BUFFERS_ARB and GL_SAMPLES_ARB
|
|
(see ARB_multisample extension) to see how many samples have been
|
|
actually allocated for your context. }
|
|
property MultiSampling: Cardinal read FMultiSampling write SetMultiSampling default 1;
|
|
|
|
property AlphaBits: Cardinal read FAlphaBits write SetAlphaBits default 0;
|
|
property DepthBits: Cardinal read FDepthBits write SetDepthBits default DefaultDepthBits;
|
|
property StencilBits: Cardinal read FStencilBits write SetStencilBits default 0;
|
|
property AUXBuffers: Cardinal read FAUXBuffers write SetAUXBuffers default 0;
|
|
property Options: TOpenGLControlOptions read FOptions write SetOptions;
|
|
end;
|
|
|
|
{ TOpenGLControl }
|
|
|
|
TOpenGLControl = class(TCustomOpenGLControl)
|
|
published
|
|
property Align;
|
|
property Anchors;
|
|
property AutoResizeViewport;
|
|
property BorderSpacing;
|
|
property Enabled;
|
|
{$IFDEF HasRGBBits}
|
|
property RedBits;
|
|
property GreenBits;
|
|
property BlueBits;
|
|
{$ENDIF}
|
|
property OpenGLMajorVersion;
|
|
property OpenGLMinorVersion;
|
|
property MultiSampling;
|
|
property AlphaBits;
|
|
property DepthBits;
|
|
property StencilBits;
|
|
property AUXBuffers;
|
|
property OnChangeBounds;
|
|
property OnClick;
|
|
property OnConstrainedResize;
|
|
property OnDblClick;
|
|
property OnDragDrop;
|
|
property OnDragOver;
|
|
property OnEnter;
|
|
property OnExit;
|
|
property OnKeyDown;
|
|
property OnKeyPress;
|
|
property OnKeyUp;
|
|
property OnMakeCurrent;
|
|
property OnMouseDown;
|
|
property OnMouseEnter;
|
|
property OnMouseLeave;
|
|
property OnMouseMove;
|
|
property OnMouseUp;
|
|
property OnMouseWheel;
|
|
property OnMouseWheelDown;
|
|
property OnMouseWheelUp;
|
|
property OnPaint;
|
|
property OnResize;
|
|
property OnShowHint;
|
|
property PopupMenu;
|
|
property ShowHint;
|
|
property Visible;
|
|
end;
|
|
|
|
{ TWSOpenGLControl }
|
|
|
|
TWSOpenGLControl = class(TWSWinControl)
|
|
published
|
|
class function CreateHandle(const AWinControl: TWinControl;
|
|
const AParams: TCreateParams): HWND; override;
|
|
class procedure DestroyHandle(const AWinControl: TWinControl); override;
|
|
class function GetDoubleBuffered(const AWinControl: TWinControl): Boolean; override;
|
|
end;
|
|
|
|
|
|
|
|
procedure Register;
|
|
|
|
|
|
implementation
|
|
|
|
{$R openglcontext.res}
|
|
|
|
var
|
|
OpenGLControlStack: TList = nil;
|
|
|
|
procedure Register;
|
|
begin
|
|
RegisterComponents('OpenGL',[TOpenGLControl]);
|
|
end;
|
|
|
|
{ TCustomOpenGLControl }
|
|
|
|
function TCustomOpenGLControl.GetSharingControls(Index: integer
|
|
): TCustomOpenGLControl;
|
|
begin
|
|
Result:=TCustomOpenGLControl(FSharingOpenGlControls[Index]);
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.SetAutoResizeViewport(const AValue: boolean);
|
|
begin
|
|
if FAutoResizeViewport=AValue then exit;
|
|
FAutoResizeViewport:=AValue;
|
|
if AutoResizeViewport
|
|
and ([csLoading,csDestroying]*ComponentState=[])
|
|
and IsVisible and HandleAllocated
|
|
and MakeCurrent then
|
|
LOpenGLViewport(Handle,0,0,Width,Height);
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.SetDebugContext(AValue: boolean);
|
|
begin
|
|
if FDebugContext=AValue then Exit;
|
|
FDebugContext:=AValue;
|
|
OpenGLAttributesChanged;
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.CMDoubleBufferedChanged(var Message: TLMessage);
|
|
begin
|
|
inherited;
|
|
OpenGLAttributesChanged;
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.SetOpenGLMajorVersion(AValue: Cardinal);
|
|
begin
|
|
if fOpenGLMajorVersion=AValue then Exit;
|
|
fOpenGLMajorVersion:=AValue;
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.SetOpenGLMinorVersion(AValue: Cardinal);
|
|
begin
|
|
if fOpenGLMinorVersion=AValue then Exit;
|
|
fOpenGLMinorVersion:=AValue;
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.SetOptions(AValue: TOpenGLControlOptions);
|
|
var
|
|
RemovedRenderAtDesignTime: boolean;
|
|
begin
|
|
if FOptions=AValue then Exit;
|
|
|
|
RemovedRenderAtDesignTime:=
|
|
(ocoRenderAtDesignTime in FOptions) and
|
|
(not (ocoRenderAtDesignTime in AValue));
|
|
|
|
FOptions:=AValue;
|
|
|
|
{ if you remove the flag ocoRenderAtDesignTime at design-time,
|
|
we need to destroy the handle. The call to OpenGLAttributesChanged
|
|
would not do this, so do it explicitly by calling ReCreateWnd
|
|
(ReCreateWnd will destroy handle, and not create new one,
|
|
since IsOpenGLRenderAllowed = false). }
|
|
if (csDesigning in ComponentState) and
|
|
RemovedRenderAtDesignTime and
|
|
HandleAllocated then
|
|
ReCreateWnd(Self);
|
|
|
|
OpenGLAttributesChanged();
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.SetRGBA(const AValue: boolean);
|
|
begin
|
|
if FRGBA=AValue then exit;
|
|
FRGBA:=AValue;
|
|
OpenGLAttributesChanged;
|
|
end;
|
|
|
|
{$IFDEF HasRGBBits}
|
|
procedure TCustomOpenGLControl.SetRedBits(const AValue: Cardinal);
|
|
begin
|
|
if FRedBits=AValue then exit;
|
|
FRedBits:=AValue;
|
|
OpenGLAttributesChanged;
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.SetGreenBits(const AValue: Cardinal);
|
|
begin
|
|
if FGreenBits=AValue then exit;
|
|
FGreenBits:=AValue;
|
|
OpenGLAttributesChanged;
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.SetBlueBits(const AValue: Cardinal);
|
|
begin
|
|
if FBlueBits=AValue then exit;
|
|
FBlueBits:=AValue;
|
|
OpenGLAttributesChanged;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure TCustomOpenGLControl.SetMultiSampling(const AMultiSampling: Cardinal);
|
|
begin
|
|
if FMultiSampling=AMultiSampling then exit;
|
|
FMultiSampling:=AMultiSampling;
|
|
OpenGLAttributesChanged;
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.SetAlphaBits(const AValue: Cardinal);
|
|
begin
|
|
if FAlphaBits=AValue then exit;
|
|
FAlphaBits:=AValue;
|
|
OpenGLAttributesChanged;
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.SetDepthBits(const AValue: Cardinal);
|
|
begin
|
|
if FDepthBits=AValue then exit;
|
|
FDepthBits:=AValue;
|
|
OpenGLAttributesChanged;
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.SetStencilBits(const AValue: Cardinal);
|
|
begin
|
|
if FStencilBits=AValue then exit;
|
|
FStencilBits:=AValue;
|
|
OpenGLAttributesChanged;
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.SetAUXBuffers(const AValue: Cardinal);
|
|
begin
|
|
if FAUXBuffers=AValue then exit;
|
|
FAUXBuffers:=AValue;
|
|
OpenGLAttributesChanged;
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.SetSharedControl(
|
|
const AValue: TCustomOpenGLControl);
|
|
begin
|
|
if FSharedOpenGLControl=AValue then exit;
|
|
if AValue=Self then
|
|
Raise Exception.Create('A control can not be shared by itself.');
|
|
// unshare old
|
|
if (AValue<>nil) and (AValue.SharedControl<>nil) then
|
|
Raise Exception.Create('Target control is sharing too. A sharing control can not be shared.');
|
|
if FSharedOpenGLControl<>nil then
|
|
FSharedOpenGLControl.FSharingOpenGlControls.Remove(Self);
|
|
// share new
|
|
if (AValue<>nil) and (csDestroying in AValue.ComponentState) then
|
|
FSharedOpenGLControl:=nil
|
|
else begin
|
|
FSharedOpenGLControl:=AValue;
|
|
if (FSharedOpenGLControl<>nil) then begin
|
|
if FSharedOpenGLControl.FSharingOpenGlControls=nil then
|
|
FSharedOpenGLControl.FSharingOpenGlControls:=TList.Create;
|
|
FSharedOpenGLControl.FSharingOpenGlControls.Add(Self);
|
|
end;
|
|
end;
|
|
// recreate handle if needed
|
|
if HandleAllocated and IsOpenGLRenderAllowed then
|
|
ReCreateWnd(Self);
|
|
end;
|
|
|
|
{ OpenGL rendering allowed, because not in design-mode or because we
|
|
should render even in design-mode. }
|
|
function TCustomOpenGLControl.IsOpenGLRenderAllowed: boolean;
|
|
begin
|
|
Result := (not (csDesigning in ComponentState)) or
|
|
(ocoRenderAtDesignTime in Options);
|
|
end;
|
|
|
|
class procedure TCustomOpenGLControl.WSRegisterClass;
|
|
const
|
|
Registered : Boolean = False;
|
|
begin
|
|
if Registered then
|
|
Exit;
|
|
inherited WSRegisterClass;
|
|
RegisterWSComponent(TCustomOpenGLControl,TWSOpenGLControl);
|
|
Registered := True;
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.WMPaint(var Message: TLMPaint);
|
|
begin
|
|
Include(FControlState, csCustomPaint);
|
|
inherited WMPaint(Message);
|
|
//debugln('TCustomGTKGLAreaControl.WMPaint A ',dbgsName(Self),' ',dbgsName(FCanvas));
|
|
if (not IsOpenGLRenderAllowed) and (FCanvas<>nil) then begin
|
|
with FCanvas do begin
|
|
if Message.DC <> 0 then
|
|
Handle := Message.DC;
|
|
Brush.Color:=clLtGray;
|
|
Pen.Color:=clRed;
|
|
Rectangle(0,0,Self.Width,Self.Height);
|
|
MoveTo(0,0);
|
|
LineTo(Self.Width,Self.Height);
|
|
MoveTo(0,Self.Height);
|
|
LineTo(Self.Width,0);
|
|
if Message.DC <> 0 then
|
|
Handle := 0;
|
|
end;
|
|
end else begin
|
|
Paint;
|
|
end;
|
|
Exclude(FControlState, csCustomPaint);
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.WMSize(var Message: TLMSize);
|
|
begin
|
|
if (Message.SizeType and Size_SourceIsInterface)>0 then
|
|
DoOnResize;
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.UpdateFrameTimeDiff;
|
|
begin
|
|
FCurrentFrameTime:=integer(GetTickCount);
|
|
if FLastFrameTime=0 then
|
|
FLastFrameTime:=FCurrentFrameTime;
|
|
// calculate time since last call:
|
|
FFrameDiffTime:=FCurrentFrameTime-FLastFrameTime;
|
|
// if the counter is reset restart:
|
|
if (FFrameDiffTime<0) then FFrameDiffTime:=1;
|
|
FLastFrameTime:=FCurrentFrameTime;
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.OpenGLAttributesChanged;
|
|
begin
|
|
if HandleAllocated and
|
|
( ([csLoading,csDestroying]*ComponentState=[]) and IsOpenGLRenderAllowed ) then
|
|
RecreateWnd(Self);
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.EraseBackground(DC: HDC);
|
|
begin
|
|
if DC=0 then ;
|
|
// everything is painted, so erasing the background is not needed
|
|
end;
|
|
|
|
constructor TCustomOpenGLControl.Create(TheOwner: TComponent);
|
|
begin
|
|
inherited Create(TheOwner);
|
|
ParentDoubleBuffered:=False;
|
|
FDoubleBuffered:=true;
|
|
FRGBA:=true;
|
|
{$IFDEF HasRGBBits}
|
|
FRedBits:=8;
|
|
FGreenBits:=8;
|
|
FBlueBits:=8;
|
|
{$ENDIF}
|
|
fOpenGLMajorVersion:=0;
|
|
fOpenGLMinorVersion:=0;
|
|
FMultiSampling:=1;
|
|
FDepthBits:=DefaultDepthBits;
|
|
ControlStyle:=ControlStyle-[csSetCaption];
|
|
if not IsOpenGLRenderAllowed then begin
|
|
FCanvas := TControlCanvas.Create;
|
|
TControlCanvas(FCanvas).Control := Self;
|
|
end else
|
|
FCompStyle:=csNonLCL;
|
|
SetInitialBounds(0, 0, 160, 90);
|
|
end;
|
|
|
|
destructor TCustomOpenGLControl.Destroy;
|
|
begin
|
|
if FSharingOpenGlControls<>nil then begin
|
|
while SharingControlCount>0 do
|
|
SharingControls[SharingControlCount-1].SharedControl:=nil;
|
|
FreeAndNil(FSharingOpenGlControls);
|
|
end;
|
|
SharedControl:=nil;
|
|
if OpenGLControlStack<>nil then begin
|
|
OpenGLControlStack.Remove(Self);
|
|
if OpenGLControlStack.Count=0 then
|
|
FreeAndNil(OpenGLControlStack);
|
|
end;
|
|
FCanvas.Free;
|
|
FCanvas:=nil;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.Paint;
|
|
begin
|
|
if IsVisible and HandleAllocated then begin
|
|
UpdateFrameTimeDiff;
|
|
if IsOpenGLRenderAllowed and ([csDestroying]*ComponentState=[]) then begin
|
|
if AutoResizeViewport then begin
|
|
if not MakeCurrent then exit;
|
|
LOpenGLViewport(Handle,0,0,Width,Height);
|
|
end;
|
|
end;
|
|
//LOpenGLClip(Handle);
|
|
DoOnPaint;
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.RealizeBounds;
|
|
begin
|
|
if IsVisible and HandleAllocated
|
|
and IsOpenGLRenderAllowed
|
|
and ([csDestroying]*ComponentState=[])
|
|
and AutoResizeViewport then begin
|
|
if MakeCurrent then
|
|
LOpenGLViewport(Handle,0,0,Width,Height);
|
|
end;
|
|
inherited RealizeBounds;
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.DoOnPaint;
|
|
begin
|
|
if Assigned(OnPaint) then begin
|
|
if not MakeCurrent then exit;
|
|
OnPaint(Self);
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.SwapBuffers;
|
|
begin
|
|
LOpenGLSwapBuffers(Handle);
|
|
end;
|
|
|
|
function TCustomOpenGLControl.MakeCurrent(SaveOldToStack: boolean): boolean;
|
|
var
|
|
Allowed: Boolean;
|
|
begin
|
|
if not IsOpenGLRenderAllowed then exit(false);
|
|
if Assigned(FOnMakeCurrent) then begin
|
|
Allowed:=true;
|
|
OnMakeCurrent(Self,Allowed);
|
|
if not Allowed then begin
|
|
Result:=False;
|
|
exit;
|
|
end;
|
|
end;
|
|
// make current
|
|
Result:=LOpenGLMakeCurrent(Handle);
|
|
if Result and SaveOldToStack then begin
|
|
// on success push on stack
|
|
if OpenGLControlStack=nil then
|
|
OpenGLControlStack:=TList.Create;
|
|
OpenGLControlStack.Add(Self);
|
|
end;
|
|
end;
|
|
|
|
function TCustomOpenGLControl.ReleaseContext: boolean;
|
|
begin
|
|
Result:=false;
|
|
if not HandleAllocated then exit;
|
|
Result:=LOpenGLReleaseContext(Handle);
|
|
end;
|
|
|
|
function TCustomOpenGLControl.RestoreOldOpenGLControl: boolean;
|
|
var
|
|
RestoredControl: TCustomOpenGLControl;
|
|
begin
|
|
Result:=false;
|
|
// check if the current context is on stack
|
|
if (OpenGLControlStack=nil) or (OpenGLControlStack.Count=0) then exit;
|
|
// pop
|
|
OpenGLControlStack.Delete(OpenGLControlStack.Count-1);
|
|
// make old control the current control
|
|
if OpenGLControlStack.Count>0 then begin
|
|
RestoredControl:=
|
|
TCustomOpenGLControl(OpenGLControlStack[OpenGLControlStack.Count-1]);
|
|
if (not LOpenGLMakeCurrent(RestoredControl.Handle)) then
|
|
exit;
|
|
end else begin
|
|
FreeAndNil(OpenGLControlStack);
|
|
end;
|
|
Result:=true;
|
|
end;
|
|
|
|
function TCustomOpenGLControl.SharingControlCount: integer;
|
|
begin
|
|
if FSharingOpenGlControls=nil then
|
|
Result:=0
|
|
else
|
|
Result:=FSharingOpenGlControls.Count;
|
|
end;
|
|
|
|
procedure TCustomOpenGLControl.Invalidate;
|
|
begin
|
|
if csCustomPaint in FControlState then exit;
|
|
inherited Invalidate;
|
|
end;
|
|
|
|
{ TWSOpenGLControl }
|
|
|
|
class function TWSOpenGLControl.CreateHandle(const AWinControl: TWinControl;
|
|
const AParams: TCreateParams): HWND;
|
|
var
|
|
OpenGlControl: TCustomOpenGLControl;
|
|
AttrControl: TCustomOpenGLControl;
|
|
begin
|
|
OpenGlControl:=AWinControl as TCustomOpenGLControl;
|
|
if not OpenGlControl.IsOpenGLRenderAllowed then
|
|
begin
|
|
// do not use "inherited CreateHandle", because the LCL changes the hierarchy at run time
|
|
Result:=TWSWinControlClass(ClassParent).CreateHandle(AWinControl,AParams);
|
|
end
|
|
else
|
|
begin
|
|
if OpenGlControl.SharedControl<>nil then
|
|
AttrControl:=OpenGlControl.SharedControl
|
|
else
|
|
AttrControl:=OpenGlControl;
|
|
Result:=LOpenGLCreateContext(OpenGlControl,WSPrivate,
|
|
OpenGlControl.SharedControl,
|
|
AttrControl.DoubleBuffered,
|
|
{$IFDEF HasMacRetinaMode}
|
|
ocoMacRetinaMode in OpenGlControl.Options,
|
|
{$ENDIF}
|
|
{$IFDEF HasRGBA}
|
|
AttrControl.RGBA,
|
|
{$ENDIF}
|
|
{$IFDEF HasDebugContext}
|
|
AttrControl.DebugContext,
|
|
{$ENDIF}
|
|
{$IFDEF HasRGBBits}
|
|
AttrControl.RedBits,
|
|
AttrControl.GreenBits,
|
|
AttrControl.BlueBits,
|
|
{$ENDIF}
|
|
{$IFDEF UsesModernGL}
|
|
AttrControl.OpenGLMajorVersion,
|
|
AttrControl.OpenGLMinorVersion,
|
|
{$ENDIF}
|
|
AttrControl.MultiSampling,
|
|
AttrControl.AlphaBits,
|
|
AttrControl.DepthBits,
|
|
AttrControl.StencilBits,
|
|
AttrControl.AUXBuffers,
|
|
AParams);
|
|
end;
|
|
end;
|
|
|
|
class procedure TWSOpenGLControl.DestroyHandle(const AWinControl: TWinControl);
|
|
begin
|
|
LOpenGLDestroyContextInfo(AWinControl);
|
|
// do not use "inherited DestroyHandle", because the LCL changes the hierarchy at run time
|
|
TWSWinControlClass(ClassParent).DestroyHandle(AWinControl);
|
|
end;
|
|
|
|
class function TWSOpenGLControl.GetDoubleBuffered(const AWinControl: TWinControl): Boolean;
|
|
begin
|
|
Result := False;
|
|
if AWinControl=nil then ;
|
|
end;
|
|
{~bk
|
|
initialization
|
|
RegisterWSComponent(TCustomOpenGLControl,TWSOpenGLControl);
|
|
}
|
|
|
|
end.
|