@@ -33,10 +33,10 @@ | |||
-K$00400000 | |||
-LE"c:\zusatzprogramme\delphi 7\Projects\Bpl" | |||
-LN"c:\zusatzprogramme\delphi 7\Projects\Bpl" | |||
-U"..\..;..\lib" | |||
-O"..\..;..\lib" | |||
-I"..\..;..\lib" | |||
-R"..\..;..\lib" | |||
-U"..\..;..\utils" | |||
-O"..\..;..\utils" | |||
-I"..\..;..\utils" | |||
-R"..\..;..\utils" | |||
-w-UNSAFE_TYPE | |||
-w-UNSAFE_CODE | |||
-w-UNSAFE_CAST |
@@ -94,7 +94,7 @@ OutputDir= | |||
UnitOutputDir= | |||
PackageDLLOutputDir= | |||
PackageDCPOutputDir= | |||
SearchPath=..\..;..\lib | |||
SearchPath=..\..;..\utils | |||
Packages=rtl;vcl;vclie;xmlrtl;inet;inetdbbde;inetdbxpress;vclx;dbrtl;soaprtl;dsnap;VclSmp;dbexpress;vcldb;dbxcds;adortl;ibxpress;vclactnband;bdertl;vclshlctrls;dclOfficeXP | |||
Conditionals= | |||
DebugSourceDirs= | |||
@@ -134,5 +134,6 @@ Comments= | |||
Count=1 | |||
Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; | |||
[HistoryLists\hlSearchPath] | |||
Count=1 | |||
Item0=..\..;..\lib | |||
Count=2 | |||
Item0=..\..;..\utils | |||
Item1=..\..;..\lib |
@@ -9,7 +9,6 @@ | |||
<Title Value="PostProcess"/> | |||
<ResourceType Value="res"/> | |||
<UseXPManifest Value="True"/> | |||
<Icon Value="0"/> | |||
</General> | |||
<i18n> | |||
<EnableI18N LFM="False"/> | |||
@@ -44,7 +43,6 @@ | |||
<ComponentName Value="MainForm"/> | |||
<HasResources Value="True"/> | |||
<ResourceBaseClass Value="Form"/> | |||
<UnitName Value="uMainForm"/> | |||
</Unit1> | |||
</Units> | |||
</ProjectOptions> | |||
@@ -56,7 +54,7 @@ | |||
</Target> | |||
<SearchPaths> | |||
<IncludeFiles Value="$(ProjOutDir)"/> | |||
<OtherUnitFiles Value="..\lib;..\.."/> | |||
<OtherUnitFiles Value="..\utils;..\.."/> | |||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> | |||
</SearchPaths> | |||
<Linking> | |||
@@ -9,7 +9,6 @@ | |||
<Title Value="SimpleFreeType"/> | |||
<ResourceType Value="res"/> | |||
<UseXPManifest Value="True"/> | |||
<Icon Value="0"/> | |||
</General> | |||
<i18n> | |||
<EnableI18N LFM="False"/> | |||
@@ -44,7 +43,6 @@ | |||
<ComponentName Value="MainForm"/> | |||
<HasResources Value="True"/> | |||
<ResourceBaseClass Value="Form"/> | |||
<UnitName Value="uMainForm"/> | |||
</Unit1> | |||
</Units> | |||
</ProjectOptions> | |||
@@ -56,7 +54,7 @@ | |||
</Target> | |||
<SearchPaths> | |||
<IncludeFiles Value="$(ProjOutDir)"/> | |||
<OtherUnitFiles Value="..\lib;..\.."/> | |||
<OtherUnitFiles Value="..\utils;..\.."/> | |||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> | |||
</SearchPaths> | |||
<Linking> | |||
@@ -9,7 +9,6 @@ | |||
<Title Value="SimpleGDI"/> | |||
<ResourceType Value="res"/> | |||
<UseXPManifest Value="True"/> | |||
<Icon Value="0"/> | |||
</General> | |||
<i18n> | |||
<EnableI18N LFM="False"/> | |||
@@ -44,7 +43,6 @@ | |||
<ComponentName Value="MainForm"/> | |||
<HasResources Value="True"/> | |||
<ResourceBaseClass Value="Form"/> | |||
<UnitName Value="uMainForm"/> | |||
</Unit1> | |||
</Units> | |||
</ProjectOptions> | |||
@@ -56,7 +54,7 @@ | |||
</Target> | |||
<SearchPaths> | |||
<IncludeFiles Value="$(ProjOutDir)"/> | |||
<OtherUnitFiles Value="..\lib;..\.."/> | |||
<OtherUnitFiles Value="..\utils;..\.."/> | |||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> | |||
</SearchPaths> | |||
<Linking> | |||
@@ -0,0 +1,365 @@ | |||
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; | |||
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; | |||
constructor Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings); overload; virtual; | |||
constructor Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings; const aVersionSettings: TglcContextVersionSettings); 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 Activate; virtual; abstract; | |||
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; | |||
procedure Share(const aContext: TglcContext); 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); | |||
begin | |||
inherited Create; | |||
fPixelFormatSettings := aPixelFormatSettings; | |||
FControl := aControl; | |||
fThreadID := 0; | |||
fEnableVsync := false; | |||
fUseVersion := false; | |||
InitOpenGL(); | |||
end; | |||
constructor TglcContext.Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings; const aVersionSettings: TglcContextVersionSettings); | |||
begin | |||
Create(aControl, aPixelFormatSettings); | |||
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; | |||
ReadImplementationProperties; | |||
ReadExtensions; | |||
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; | |||
initialization | |||
{$IFDEF fpc}TglcContext.{$ENDIF}fMainContextThreadID := 0; | |||
end. | |||
@@ -0,0 +1,572 @@ | |||
unit uglcContextGtk2GLX; | |||
{ Package: OpenGLCore | |||
Prefix: glc - OpenGL Core | |||
Beschreibung: diese Unit enthält eine Klassen-Kapselung für OpenGL Kontexte für Linux | |||
Hint: diese Unit sollte niemals direkt genutzt werden (siehe uglcContext) } | |||
interface | |||
uses | |||
SysUtils, Controls, uglcContext, LCLType, XUtil, XLib, gdk2x, gtk2, gdk2, dglOpenGL, | |||
LMessages, uglcContextGtkCustomVisual; | |||
type | |||
EGLXError = class(EGLError); | |||
TRenderControl = class(TCustomVisualControl) | |||
private | |||
fTarget: TWinControl; | |||
protected | |||
procedure WndProc(var Message: TLMessage); override; | |||
public | |||
property Target: TWinControl read fTarget write fTarget; | |||
end; | |||
{ TglcContextGtk2GLX } | |||
TglcContextGtk2GLX = class(TglcContext) | |||
private | |||
FVisual: PXVisualInfo; | |||
FDisplay: PDisplay; | |||
FWidget: PGtkWidget; | |||
FContext: GLXContext; | |||
FRenderControl: TRenderControl; | |||
procedure UpdateVisual(const aControl: TWinControl); | |||
protected | |||
procedure OpenContext; override; | |||
public | |||
constructor Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings); override; overload; | |||
constructor Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings; const aVersionSettings: TglcContextVersionSettings); override; overload; | |||
destructor Destroy; override; | |||
procedure CloseContext; override; | |||
procedure Activate; override; | |||
procedure Deactivate; override; | |||
function IsActive: boolean; override; | |||
procedure SwapBuffers; override; | |||
procedure SetSwapInterval(const aInterval: GLint); override; | |||
procedure Share(const aContext: TglcContext); override; | |||
class function ChangeDisplaySettings(const aWidth, aHeight, | |||
aBitPerPixel, aFreq: Integer; const aFlags: TglcDisplayFlags): Boolean; override; | |||
class function IsAnyContextActive: boolean; override; | |||
end; | |||
implementation | |||
type | |||
TGLIntArray = packed array of GLInt; | |||
{$region messages -fold} | |||
procedure TRenderControl.WndProc(var Message: TLMessage); | |||
begin | |||
case Message.msg of | |||
//LM_ACTIVATEITEM, | |||
//LM_CHANGED, | |||
//LM_FOCUS, | |||
LM_CLICKED, | |||
//LM_RELEASED, | |||
LM_ENTER, | |||
LM_LEAVE, | |||
//LM_CHECKRESIZE, | |||
//LM_SETEDITABLE, | |||
//LM_MOVEWORD, | |||
//LM_MOVEPAGE, | |||
//LM_MOVETOROW, | |||
//LM_MOVETOCOLUMN, | |||
//LM_KILLCHAR, | |||
//LM_KILLWORD, | |||
//LM_KILLLINE, | |||
//LM_CLOSEQUERY, | |||
//LM_DRAGSTART, | |||
//LM_MONTHCHANGED, | |||
//LM_YEARCHANGED, | |||
//LM_DAYCHANGED, | |||
LM_LBUTTONTRIPLECLK, | |||
LM_LBUTTONQUADCLK, | |||
LM_MBUTTONTRIPLECLK, | |||
LM_MBUTTONQUADCLK, | |||
LM_RBUTTONTRIPLECLK, | |||
LM_RBUTTONQUADCLK, | |||
LM_MOUSEENTER, | |||
LM_MOUSELEAVE, | |||
LM_XBUTTONTRIPLECLK, | |||
LM_XBUTTONQUADCLK, | |||
//SC_SIZE, | |||
//SC_MOVE, | |||
//SC_MINIMIZE, | |||
//SC_MAXIMIZE, | |||
//SC_NEXTWINDOW, | |||
//SC_PREVWINDOW, | |||
//SC_CLOSE, | |||
SC_VSCROLL, | |||
SC_HSCROLL, | |||
SC_MOUSEMENU, | |||
SC_KEYMENU, | |||
//SC_ARRANGE, | |||
//SC_RESTORE, | |||
//SC_TASKLIST, | |||
//SC_SCREENSAVE, | |||
//SC_HOTKEY, | |||
//SC_DEFAULT, | |||
//SC_MONITORPOWER, | |||
//SC_CONTEXTHELP, | |||
//SC_SEPARATOR, | |||
//LM_MOVE, | |||
//LM_SIZE, | |||
LM_ACTIVATE, | |||
LM_SETFOCUS, | |||
LM_KILLFOCUS, | |||
//LM_ENABLE, | |||
//LM_GETTEXTLENGTH, | |||
//LM_SHOWWINDOW, | |||
//LM_CANCELMODE, | |||
//LM_DRAWITEM, | |||
//LM_MEASUREITEM, | |||
//LM_DELETEITEM, | |||
//LM_VKEYTOITEM, | |||
//LM_CHARTOITEM, | |||
//LM_COMPAREITEM, | |||
//LM_WINDOWPOSCHANGING, | |||
//LM_WINDOWPOSCHANGED, | |||
//LM_NOTIFY, | |||
//LM_HELP, | |||
//LM_NOTIFYFORMAT, | |||
//LM_CONTEXTMENU, | |||
//LM_NCCALCSIZE, | |||
//LM_NCHITTEST, | |||
//LM_NCPAINT, | |||
//LM_NCACTIVATE, | |||
//LM_GETDLGCODE, | |||
LM_NCMOUSEMOVE, | |||
LM_NCLBUTTONDOWN, | |||
LM_NCLBUTTONUP, | |||
LM_NCLBUTTONDBLCLK, | |||
LM_KEYDOWN, | |||
LM_KEYUP, | |||
LM_CHAR, | |||
LM_SYSKEYDOWN, | |||
LM_SYSKEYUP, | |||
LM_SYSCHAR, | |||
LM_COMMAND, | |||
LM_SYSCOMMAND, | |||
LM_TIMER, | |||
LM_HSCROLL, | |||
LM_VSCROLL, | |||
//LM_CTLCOLORMSGBOX, | |||
//LM_CTLCOLOREDIT, | |||
//LM_CTLCOLORLISTBOX, | |||
//LM_CTLCOLORBTN, | |||
//LM_CTLCOLORDLG, | |||
//LM_CTLCOLORSCROLLBAR, | |||
//LM_CTLCOLORSTATIC, | |||
LM_MOUSEMOVE, | |||
LM_LBUTTONDOWN, | |||
LM_LBUTTONUP, | |||
LM_LBUTTONDBLCLK, | |||
LM_RBUTTONDOWN, | |||
LM_RBUTTONUP, | |||
LM_RBUTTONDBLCLK, | |||
LM_MBUTTONDOWN, | |||
LM_MBUTTONUP, | |||
LM_MBUTTONDBLCLK, | |||
LM_MOUSEWHEEL, | |||
LM_XBUTTONDOWN, | |||
LM_XBUTTONUP, | |||
LM_XBUTTONDBLCLK, | |||
//LM_PARENTNOTIFY, | |||
//LM_CAPTURECHANGED, | |||
//LM_DROPFILES, | |||
//LM_SELCHANGE, | |||
LM_CUT, | |||
LM_COPY, | |||
LM_PASTE, | |||
//LM_CLEAR, | |||
//LM_CONFIGUREEVENT, | |||
//LM_EXIT, | |||
//LM_QUIT, | |||
//LM_NULL, | |||
//LM_PAINT, | |||
//LM_ERASEBKGND, | |||
//LM_SETCURSOR, | |||
//LM_SETFONT: | |||
//CM_ACTIVATE, | |||
//CM_DEACTIVATE, | |||
//CM_FOCUSCHANGED, | |||
//CM_PARENTFONTCHANGED, | |||
//CM_PARENTCOLORCHANGED, | |||
//CM_HITTEST, | |||
//CM_VISIBLECHANGED, | |||
//CM_ENABLEDCHANGED, | |||
//CM_COLORCHANGED, | |||
//CM_FONTCHANGED, | |||
//CM_CURSORCHANGED, | |||
//CM_TEXTCHANGED, | |||
CM_MOUSEENTER, | |||
CM_MOUSELEAVE, | |||
//CM_MENUCHANGED, | |||
//CM_APPSYSCOMMAND, | |||
//CM_BUTTONPRESSED, | |||
//CM_SHOWINGCHANGED, | |||
//CM_ENTER, | |||
//CM_EXIT, | |||
//CM_DESIGNHITTEST, | |||
//CM_ICONCHANGED, | |||
//CM_WANTSPECIALKEY, | |||
//CM_RELEASE, | |||
//CM_FONTCHANGE, | |||
//CM_TABSTOPCHANGED, | |||
//CM_UIACTIVATE, | |||
//CM_CONTROLLISTCHANGE, | |||
//CM_GETDATALINK, | |||
//CM_CHILDKEY, | |||
//CM_HINTSHOW, | |||
//CM_SYSFONTCHANGED, | |||
//CM_CONTROLCHANGE, | |||
//CM_CHANGED, | |||
//CM_BORDERCHANGED, | |||
//CM_BIDIMODECHANGED, | |||
//CM_PARENTBIDIMODECHANGED, | |||
//CM_ALLCHILDRENFLIPPED, | |||
//CM_ACTIONUPDATE, | |||
//CM_ACTIONEXECUTE, | |||
//CM_HINTSHOWPAUSE, | |||
//CM_DOCKNOTIFICATION, | |||
CM_MOUSEWHEEL, | |||
//CM_APPSHOWBTNGLYPHCHANGED, | |||
//CM_APPSHOWMENUGLYPHCHANGED, | |||
//CN_BASE, | |||
//CN_CHARTOITEM, | |||
//CN_COMMAND, | |||
//CN_COMPAREITEM, | |||
//CN_CTLCOLORBTN, | |||
//CN_CTLCOLORDLG, | |||
//CN_CTLCOLOREDIT, | |||
//CN_CTLCOLORLISTBOX, | |||
//CN_CTLCOLORMSGBOX, | |||
//CN_CTLCOLORSCROLLBAR, | |||
//CN_CTLCOLORSTATIC, | |||
//CN_DELETEITEM, | |||
//CN_DRAWITEM, | |||
CN_HSCROLL, | |||
//CN_MEASUREITEM, | |||
//CN_PARENTNOTIFY, | |||
//CN_VKEYTOITEM, | |||
CN_VSCROLL, | |||
CN_KEYDOWN, | |||
CN_KEYUP, | |||
CN_CHAR, | |||
CN_SYSKEYUP, | |||
CN_SYSKEYDOWN, | |||
CN_SYSCHAR, | |||
CN_NOTIFY: | |||
begin | |||
if Assigned(fTarget) then | |||
Message.Result := fTarget.Perform(Message.msg, Message.wParam, Message.lParam); | |||
end; | |||
end; | |||
inherited WndProc(Message); | |||
end; | |||
{$endregion} | |||
function CreateOpenGLContextAttrList(UseFB: boolean; pf: TglcContextPixelFormatSettings): TGLIntArray; | |||
var | |||
p: integer; | |||
procedure Add(i: integer); | |||
begin | |||
SetLength(Result, p+1); | |||
Result[p]:=i; | |||
inc(p); | |||
end; | |||
procedure CreateList; | |||
begin | |||
if UseFB then begin Add(GLX_X_RENDERABLE); Add(1); end; | |||
if pf.DoubleBuffered then begin | |||
if UseFB then begin | |||
Add(GLX_DOUBLEBUFFER); Add(1); | |||
end else | |||
Add(GLX_DOUBLEBUFFER); | |||
end; | |||
if not UseFB and (pf.ColorBits>24) then Add(GLX_RGBA); | |||
if UseFB then begin | |||
Add(GLX_DRAWABLE_TYPE); | |||
Add(GLX_WINDOW_BIT); | |||
end; | |||
Add(GLX_RED_SIZE); Add(8); | |||
Add(GLX_GREEN_SIZE); Add(8); | |||
Add(GLX_BLUE_SIZE); Add(8); | |||
if pf.ColorBits>24 then | |||
Add(GLX_ALPHA_SIZE); Add(8); | |||
Add(GLX_DEPTH_SIZE); Add(pf.DepthBits); | |||
Add(GLX_STENCIL_SIZE); Add(pf.StencilBits); | |||
Add(GLX_AUX_BUFFERS); Add(pf.AUXBuffers); | |||
if pf.MultiSampling > 1 then begin | |||
Add(GLX_SAMPLE_BUFFERS_ARB); Add(1); | |||
Add(GLX_SAMPLES_ARB); Add(pf.MultiSampling); | |||
end; | |||
Add(0); { 0 = X.None (be careful: GLX_NONE is something different) } | |||
end; | |||
begin | |||
SetLength(Result, 0); | |||
p:=0; | |||
CreateList; | |||
end; | |||
function FBglXChooseVisual(dpy:PDisplay; screen:longint; attrib_list:Plongint):PXVisualInfo; | |||
type | |||
PGLXFBConfig = ^GLXFBConfig; | |||
var | |||
FBConfigsCount: integer; | |||
FBConfigs: PGLXFBConfig; | |||
FBConfig: GLXFBConfig; | |||
begin | |||
Result:= nil; | |||
FBConfigsCount:=0; | |||
FBConfigs:= glXChooseFBConfig(dpy, screen, attrib_list, @FBConfigsCount); | |||
if FBConfigsCount = 0 then | |||
exit; | |||
{ just choose the first FB config from the FBConfigs list. | |||
More involved selection possible. } | |||
FBConfig := FBConfigs^; | |||
Result:=glXGetVisualFromFBConfig(dpy, FBConfig); | |||
end; | |||
{ TglcContextGtk2GLX } | |||
procedure TglcContextGtk2GLX.UpdateVisual(const aControl: TWinControl); | |||
var | |||
attrList: TGLIntArray; | |||
drawable: PGdkDrawable; | |||
begin | |||
if not Assigned(aControl) then | |||
raise EArgumentException.Create('aControl is not assigned'); | |||
{ | |||
Temporary (realized) widget to get to display | |||
} | |||
FWidget:= {%H-}PGtkWidget(PtrUInt(aControl.Handle)); | |||
gtk_widget_realize(FWidget); | |||
drawable:= GTK_WIDGET(FWidget)^.window; | |||
FDisplay:= GDK_WINDOW_XDISPLAY(drawable); | |||
{ | |||
Find a suitable visual from PixelFormat using GLX 1.3 FBConfigs or | |||
old-style Visuals | |||
} | |||
if Assigned(glXChooseFBConfig) then begin | |||
attrList := CreateOpenGLContextAttrList(true, fPixelFormatSettings); | |||
FVisual := FBglXChooseVisual(FDisplay, DefaultScreen(FDisplay), @attrList[0]); | |||
if not Assigned(FVisual) and (fPixelFormatSettings.MultiSampling > 1) then begin | |||
fPixelFormatSettings.MultiSampling := 1; | |||
attrList := CreateOpenGLContextAttrList(true, fPixelFormatSettings); | |||
FVisual := FBglXChooseVisual(FDisplay, DefaultScreen(FDisplay), @attrList[0]); | |||
end; | |||
end; | |||
if not Assigned(FVisual) then begin | |||
attrList := CreateOpenGLContextAttrList(false, fPixelFormatSettings); | |||
FVisual := glXChooseVisual(FDisplay, DefaultScreen(FDisplay), @attrList[0]); | |||
if not Assigned(FVisual) and (fPixelFormatSettings.MultiSampling > 1) then begin | |||
fPixelFormatSettings.MultiSampling := 1; | |||
attrList := CreateOpenGLContextAttrList(false, fPixelFormatSettings); | |||
FVisual := glXChooseVisual(FDisplay, DefaultScreen(FDisplay), @attrList[0]); | |||
end; | |||
end; | |||
if not Assigned(FVisual) then | |||
raise EGLXError.Create('choose visual failed'); | |||
{ | |||
Most widgets inherit the drawable of their parent. In contrast to Windows, descending from | |||
TWinControl does not mean it's actually always a window of its own. | |||
Famous example: TPanel is just a frame painted on a canvas. | |||
Also, the LCL does somethin weird to colormaps in window creation, so we have | |||
to use a custom widget here to have full control about visual selection. | |||
} | |||
FRenderControl:= TRenderControl.Create(aControl, FVisual^.visual^.visualid); | |||
try | |||
FRenderControl.Parent := aControl; | |||
FRenderControl.HandleNeeded; | |||
FRenderControl.Target := aControl; | |||
except | |||
FreeAndNil(FRenderControl); | |||
raise; | |||
end; | |||
{ | |||
Real Widget handle, unrealized!!! | |||
} | |||
FWidget:= FRenderControl.Widget; | |||
gtk_widget_realize(FWidget); | |||
drawable:= GTK_WIDGET(FWidget)^.window; | |||
FDisplay:= GDK_WINDOW_XDISPLAY(drawable); | |||
// FRenderControl.Align:= alClient breaks the context or something | |||
FRenderControl.BoundsRect := aControl.ClientRect; | |||
FRenderControl.Anchors := [akLeft, akTop, akRight, akBottom]; | |||
end; | |||
procedure TglcContextGtk2GLX.OpenContext; | |||
var | |||
Attribs: array of GLint; | |||
tmpContext: GLXContext; | |||
glxID: GLXDrawable; | |||
begin | |||
inherited OpenContext; | |||
if not Assigned(FVisual) then | |||
raise EGLXError.Create('Failed to find Visual'); | |||
tmpContext := glXCreateContext(FDisplay, FVisual, nil, true); | |||
if fUseVersion and | |||
(fVersionSettings.Major <> GLC_CONTEXT_VERSION_UNKNOWN) and | |||
(fVersionSettings.Minor <> GLC_CONTEXT_VERSION_UNKNOWN) then | |||
begin | |||
// Set attributes to describe our requested context | |||
SetLength(Attribs, 5); | |||
Attribs[0] := WGL_CONTEXT_MAJOR_VERSION_ARB; | |||
Attribs[1] := fVersionSettings.Major; | |||
Attribs[2] := WGL_CONTEXT_MINOR_VERSION_ARB; | |||
Attribs[3] := fVersionSettings.Minor; | |||
// Add context flag for forward compatible context | |||
// Forward compatible means no more support for legacy functions like | |||
// immediate mode (glvertex, glrotate, gltranslate, etc.) | |||
if fVersionSettings.ForwardCompatible then begin | |||
SetLength(Attribs, Length(Attribs)+2); | |||
Attribs[4] := WGL_CONTEXT_FLAGS_ARB; | |||
Attribs[5] := WGL_CONTEXT_FORWARD_COMPATIBLE_BIT_ARB; | |||
end; | |||
// Attribute flags must be finalized with a zero | |||
SetLength(Attribs, 1); | |||
Attribs[High(Attribs)] := 0; | |||
glxID := GDK_DRAWABLE_XID(GTK_WIDGET(FWidget)^.window); | |||
glXMakeCurrent(FDisplay, glxID, tmpContext); | |||
ReadImplementationProperties; | |||
if not Assigned(glXCreateContextAttribsARB) or not GLX_ARB_create_context then begin | |||
glXDestroyContext(FDisplay, tmpContext); | |||
raise Exception.Create('GLX_ARB_create_context not supported'); | |||
end; | |||
FContext := glXCreateContextAttribsARB(FDisplay, FVisual, nil, true, @Attribs[0]); | |||
glXDestroyContext(FDisplay, tmpContext); | |||
end else | |||
FContext := tmpContext; | |||
if (FContext = nil) then | |||
raise EGLXError.Create('Failed to create Context'); | |||
end; | |||
constructor TglcContextGtk2GLX.Create(const aControl: TWinControl; | |||
const aPixelFormatSettings: TglcContextPixelFormatSettings); | |||
begin | |||
inherited Create(aControl, aPixelFormatSettings); | |||
UpdateVisual(aControl); | |||
end; | |||
constructor TglcContextGtk2GLX.Create(const aControl: TWinControl; | |||
const aPixelFormatSettings: TglcContextPixelFormatSettings; | |||
const aVersionSettings: TglcContextVersionSettings); | |||
begin | |||
inherited Create(aControl, aPixelFormatSettings, aVersionSettings); | |||
UpdateVisual(aControl); | |||
end; | |||
destructor TglcContextGtk2GLX.Destroy; | |||
begin | |||
FreeAndNil(FRenderControl); | |||
XFree(FVisual); | |||
inherited Destroy; | |||
end; | |||
procedure TglcContextGtk2GLX.CloseContext; | |||
begin | |||
if not Assigned(FWidget) then exit; | |||
if Assigned(FContext) then | |||
glXDestroyContext(FDisplay, FContext); | |||
FreeAndNil(FRenderControl); | |||
end; | |||
procedure TglcContextGtk2GLX.Activate; | |||
var | |||
glxID: GLXDrawable; | |||
begin | |||
if not Assigned(FWidget) then exit; | |||
// make sure the widget is realized | |||
gtk_widget_realize(FWidget); | |||
if not GTK_WIDGET_REALIZED(FWidget) then exit; | |||
// make current | |||
glxID := GDK_DRAWABLE_XID(GTK_WIDGET(FWidget)^.window); | |||
glXMakeCurrent(FDisplay, glxID, FContext); | |||
end; | |||
procedure TglcContextGtk2GLX.Deactivate; | |||
var | |||
glxID: GLXDrawable; | |||
begin | |||
if not Assigned(FWidget) then exit; | |||
glxID := GDK_DRAWABLE_XID(GTK_WIDGET(FWidget)^.window); | |||
glXMakeCurrent(FDisplay, glxID, nil); | |||
end; | |||
function TglcContextGtk2GLX.IsActive: boolean; | |||
var | |||
glxID: GLXDrawable; | |||
begin | |||
glxID := GDK_DRAWABLE_XID(GTK_WIDGET(FWidget)^.window); | |||
Result:= (FContext = glXGetCurrentContext()) and | |||
Assigned(FWidget) and | |||
(glxID = glXGetCurrentDrawable()); | |||
end; | |||
procedure TglcContextGtk2GLX.SwapBuffers; | |||
var | |||
glxID: GLXDrawable; | |||
begin | |||
if not Assigned(FWidget) then exit; | |||
glxID := GDK_DRAWABLE_XID(GTK_WIDGET(FWidget)^.window); | |||
glXSwapBuffers(FDisplay, glxID); | |||
end; | |||
procedure TglcContextGtk2GLX.SetSwapInterval(const aInterval: GLint); | |||
var | |||
drawable: PGdkDrawable; | |||
begin | |||
drawable:= GTK_WIDGET(FWidget)^.window; | |||
if GLX_EXT_swap_control then | |||
glXSwapIntervalEXT(FDisplay, GDK_WINDOW_XWINDOW(drawable), aInterval); | |||
end; | |||
procedure TglcContextGtk2GLX.Share(const aContext: TglcContext); | |||
begin | |||
raise Exception.Create('not yet implemented'); | |||
end; | |||
class function TglcContextGtk2GLX.{%H-}ChangeDisplaySettings(const aWidth, aHeight, | |||
aBitPerPixel, aFreq: Integer; const aFlags: TglcDisplayFlags): Boolean; | |||
begin | |||
raise Exception.Create('not yet implemented'); | |||
end; | |||
class function TglcContextGtk2GLX.IsAnyContextActive: boolean; | |||
begin | |||
Result:= (glXGetCurrentContext()<>nil) and (glXGetCurrentDrawable()<>0); | |||
end; | |||
end. | |||
@@ -0,0 +1,225 @@ | |||
unit uglcContextGtkCustomVisual; | |||
{ Package: OpenGLCore | |||
Prefix: glc - OpenGL Core | |||
Beschreibung: diese Unit enthält Klassen zum Erzeugen von Visuals (unter Linux), | |||
auf denen ein OpenGL Kontext erstellt werden kann } | |||
{$mode objfpc}{$H+} | |||
interface | |||
uses | |||
Classes, SysUtils, Controls, LCLType, InterfaceBase, LMessages, WSLCLClasses, WSControls, | |||
X, XLib, glib2, gdk2, gdk2x, gtk2, Gtk2Def, Gtk2Int; | |||
type | |||
TCustomVisualControl = class(TWinControl) | |||
private | |||
FIntWidget: PGtkWidget; | |||
FVisualID: TVisualID; | |||
protected | |||
function WSCreateHandle({%H-}const WSPrivate: TWSPrivateClass; const AParams: TCreateParams): TLCLIntfHandle; | |||
procedure WSBeforeDestroyHandle; | |||
public | |||
constructor Create(TheOwner: TComponent; const aVisualID: TVisualID); overload; | |||
property Widget: PGtkWidget read FIntWidget; | |||
end; | |||
TWSCustomVisualControl = class(TWSWinControl) | |||
published | |||
class function CreateHandle(const AWinControl: TWinControl; | |||
const AParams: TCreateParams): TLCLIntfHandle; override; | |||
class procedure DestroyHandle(const AWinControl: TWinControl); override; | |||
end; | |||
implementation | |||
type | |||
PGtkCustomWidget = ^TGtkCustomWidget; | |||
TGtkCustomWidget = record | |||
darea: TGtkDrawingArea; | |||
end; | |||
PGtkCustomWidgetClass = ^TGtkCustomWidgetClass; | |||
TGtkCustomWidgetClass = record | |||
parent_class: TGtkDrawingAreaClass; | |||
end; | |||
var | |||
custom_widget_type: TGtkType = 0; | |||
custom_widget_parent_class: Pointer = nil; | |||
function GTK_TYPE_CUSTOM_WIDGET: TGtkType; forward; | |||
procedure g_return_if_fail(b: boolean; const Msg: string); | |||
begin | |||
if not b then raise Exception.Create(Msg); | |||
end; | |||
procedure g_return_if_fail(b: boolean); | |||
begin | |||
g_return_if_fail(b,''); | |||
end; | |||
function GTK_IS_CUSTOM_WIDGET(obj: Pointer): Boolean; | |||
begin | |||
GTK_IS_CUSTOM_WIDGET:=GTK_CHECK_TYPE(obj,GTK_TYPE_CUSTOM_WIDGET); | |||
end; | |||
function GTK_CUSTOM_WIDGET(obj: Pointer): PGtkCustomWidget; | |||
begin | |||
g_return_if_fail(GTK_IS_CUSTOM_WIDGET(obj),''); | |||
Result:=PGtkCustomWidget(obj); | |||
end; | |||
procedure gtk_custom_widget_init(custom_widget: PGTypeInstance; theClass: gpointer); cdecl; | |||
begin | |||
if theClass=nil then ; | |||
//DebugLn(['gtk_custom_widget_init START']); | |||
gtk_widget_set_double_buffered(PGtkWidget(custom_widget),gdkFALSE); | |||
GTK_WIDGET_UNSET_FLAGS(PGtkWidget(custom_widget),GTK_NO_WINDOW); | |||
//DebugLn(['gtk_custom_widget_init END']); | |||
end; | |||
procedure gtk_custom_widget_destroy(obj: PGtkObject); cdecl; | |||
begin | |||
g_return_if_fail (obj <>nil,''); | |||
g_return_if_fail (GTK_IS_CUSTOM_WIDGET(obj),''); | |||
if Assigned(GTK_OBJECT_CLASS(custom_widget_parent_class)^.destroy) then | |||
GTK_OBJECT_CLASS(custom_widget_parent_class)^.destroy(obj); | |||
end; | |||
procedure gtk_custom_widget_class_init(klass: Pointer); cdecl; | |||
var | |||
object_class: PGtkObjectClass; | |||
begin | |||
custom_widget_parent_class := gtk_type_class(gtk_drawing_area_get_type()); | |||
g_return_if_fail(custom_widget_parent_class<>nil,'gtk_custom_widget_class_init parent_class=nil'); | |||
object_class := PGtkObjectClass(klass); | |||
g_return_if_fail(object_class<>nil,'gtk_custom_widget_class_init object_class=nil'); | |||
object_class^.destroy := @gtk_custom_widget_destroy; | |||
end; | |||
function custom_widget_size_allocateCB(Widget: PGtkWidget; Size: pGtkAllocation; | |||
Data: gPointer): GBoolean; cdecl; | |||
const | |||
CallBackDefaultReturn = {$IFDEF GTK2}false{$ELSE}true{$ENDIF}; | |||
var | |||
SizeMsg: TLMSize; | |||
GtkWidth, GtkHeight: integer; | |||
LCLControl: TWinControl; | |||
begin | |||
Result := CallBackDefaultReturn; | |||
if not GTK_WIDGET_REALIZED(Widget) then begin | |||
// the widget is not yet realized, so this GTK resize was not a user change. | |||
// => ignore | |||
exit; | |||
end; | |||
if Size=nil then ; | |||
LCLControl:=TWinControl(Data); | |||
if LCLControl=nil then exit; | |||
//DebugLn(['gtkglarea_size_allocateCB ',DbgSName(LCLControl)]); | |||
gtk_widget_get_size_request(Widget, @GtkWidth, @GtkHeight); | |||
SizeMsg.Msg:=0; | |||
FillChar(SizeMsg,SizeOf(SizeMsg),0); | |||
with SizeMsg do | |||
begin | |||
Result := 0; | |||
Msg := LM_SIZE; | |||
SizeType := Size_SourceIsInterface; | |||
Width := SmallInt(GtkWidth); | |||
Height := SmallInt(GtkHeight); | |||
end; | |||
//DebugLn(['gtkglarea_size_allocateCB ',GtkWidth,',',GtkHeight]); | |||
LCLControl.WindowProc(TLMessage(SizeMsg)); | |||
end; | |||
function GTK_TYPE_CUSTOM_WIDGET: TGtkType; | |||
const | |||
custom_widget_type_name = 'GtkGLArea'; | |||
custom_widget_info: TGtkTypeInfo = ( | |||
type_name: custom_widget_type_name; | |||
object_size: SizeOf(TGtkCustomWidget); | |||
class_size: SizeOf(TGtkCustomWidgetClass); | |||
class_init_func: @gtk_custom_widget_class_init; | |||
object_init_func: @gtk_custom_widget_init; | |||
reserved_1: nil; | |||
reserved_2: nil; | |||
base_class_init_func: nil; | |||
); | |||
begin | |||
if (custom_widget_type=0) then begin | |||
custom_widget_type:=gtk_type_unique(gtk_drawing_area_get_type(),@custom_widget_info); | |||
end; | |||
Result:=custom_widget_type; | |||
end; | |||
{ TCustomVisualControl } | |||
constructor TCustomVisualControl.Create(TheOwner: TComponent; const aVisualID: TVisualID); | |||
begin | |||
inherited Create(TheOwner); | |||
FIntWidget:= nil; | |||
fVisualID:= aVisualID; | |||
SetBounds(0, 0, 200, 200); | |||
end; | |||
function TCustomVisualControl.WSCreateHandle(const WSPrivate: TWSPrivateClass; const AParams: TCreateParams): TLCLIntfHandle; | |||
var | |||
cmap: PGdkColormap; | |||
gdkvis: PGdkVisual; | |||
begin | |||
// is the requested VisualID different from what the widget would get? | |||
cmap := gdk_colormap_get_system; | |||
gdkvis:= gdk_colormap_get_visual(cmap); | |||
if XVisualIDFromVisual(gdk_x11_visual_get_xvisual(gdkvis)) <> FVisualID then begin | |||
gdkvis:= gdkx_visual_get(FVisualID); | |||
cmap := gdk_colormap_new(gdkvis, false); | |||
end; | |||
FIntWidget:= gtk_type_new(GTK_TYPE_CUSTOM_WIDGET); | |||
gtk_widget_set_colormap(FIntWidget, cmap); | |||
Result:= TLCLIntfHandle({%H-}PtrUInt(FIntWidget)); | |||
PGtkobject(FIntWidget)^.flags:= PGtkobject(FIntWidget)^.flags or GTK_CAN_FOCUS; | |||
TGTK2WidgetSet(WidgetSet).FinishCreateHandle(Self,FIntWidget,AParams); | |||
g_signal_connect_after(FIntWidget, 'size-allocate', TGTKSignalFunc(@custom_widget_size_allocateCB), Self); | |||
end; | |||
procedure TCustomVisualControl.WSBeforeDestroyHandle; | |||
begin | |||
if not HandleAllocated then exit; | |||
end; | |||
{ TWSCustomVisualControl } | |||
class function TWSCustomVisualControl.CreateHandle(const AWinControl: TWinControl; const AParams: TCreateParams): TLCLIntfHandle; | |||
begin | |||
if csDesigning in AWinControl.ComponentState then begin | |||
// do not use "inherited CreateHandle", because the LCL changes the hierarchy at run time | |||
Result:= TWSWinControlClass(ClassParent).CreateHandle(AWinControl,AParams); | |||
end else | |||
Result:= (AWinControl as TCustomVisualControl).WSCreateHandle(WSPrivate, AParams); | |||
end; | |||
class procedure TWSCustomVisualControl.DestroyHandle(const AWinControl: TWinControl); | |||
begin | |||
(AWinControl as TCustomVisualControl).WSBeforeDestroyHandle; | |||
// do not use "inherited DestroyHandle", because the LCL changes the hierarchy at run time | |||
TWSWinControlClass(ClassParent).DestroyHandle(AWinControl); | |||
end; | |||
initialization | |||
RegisterWSComponent(TCustomVisualControl,TWSCustomVisualControl); | |||
end. | |||
@@ -0,0 +1,432 @@ | |||
unit uglcContextWGL; | |||
{ Package: OpenGLCore | |||
Prefix: glc - OpenGL Core | |||
Beschreibung: diese Unit enthält eine Klassen-Kapselung für OpenGL Kontexte für Windows | |||
Hint: diese Unit sollte niemals direkt genutzt werden (siehe uglcContext) } | |||
interface | |||
uses | |||
Classes, SysUtils, Forms, Windows, uglcContext, dglOpenGL, Controls; | |||
type | |||
EWGLError = class(EGLError); | |||
{ TglcContextWGL } | |||
TglcContextWGL = class(TglcContext) | |||
private | |||
FDC: HDC; | |||
FRC: HGLRC; | |||
fHandle: THandle; | |||
fPixelFormat: Integer; | |||
{%H-}constructor Create(const aControl: TWinControl); overload; | |||
protected | |||
procedure UpdatePixelFormat; | |||
procedure OpenContext; override; | |||
function FindPixelFormat: Integer; | |||
function FindPixelFormatNoAA: Integer; | |||
procedure OpenFromPF(PixelFormat: Integer); | |||
public | |||
constructor Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings); overload; override; | |||
constructor Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings; const aVersionSettings: TglcContextVersionSettings); overload; override; | |||
procedure CloseContext; override; | |||
procedure Activate; override; | |||
procedure Deactivate; override; | |||
function IsActive: boolean; override; | |||
procedure SwapBuffers; override; | |||
procedure SetSwapInterval(const aInterval: GLint); override; | |||
function GetSwapInterval: GLint; override; | |||
procedure Share(const aContext: TglcContext); override; | |||
class function ChangeDisplaySettings(const aWidth, aHeight, aBitPerPixel, aFreq: Integer; | |||
const aFlags: TglcDisplayFlags): Boolean; override; | |||
class function IsAnyContextActive: boolean; override; | |||
end; | |||
implementation | |||
{ TglcContextWGL } | |||
constructor TglcContextWGL.Create(const aControl: TWinControl); | |||
begin | |||
inherited Create(aControl, MakePF()); | |||
fHandle := aControl.Handle; | |||
end; | |||
procedure TglcContextWGL.UpdatePixelFormat; | |||
begin | |||
fPixelFormat := FindPixelFormat; | |||
if (fPixelFormat = 0) then begin | |||
// try without MS | |||
fPixelFormatSettings.MultiSampling := 1; | |||
fPixelFormat := FindPixelFormat; | |||
end; | |||
end; | |||
procedure TglcContextWGL.OpenContext; | |||
begin | |||
inherited OpenContext; | |||
OpenFromPF(fPixelFormat); | |||
end; | |||
function TglcContextWGL.FindPixelFormat: Integer; | |||
var | |||
OldRC: HGLRC; OldDC: HDC; | |||
tmpWnd: TForm; | |||
tmpContext: TglcContextWGL; | |||
pf, i, max: integer; | |||
Count: GLuint; | |||
PFList, SampleList: array[0..31] of GLint; | |||
procedure ChoosePF(pPFList, pSampleList: PGLint; MaxCount: integer); | |||
var | |||
//ARB_Erweiterung vorhanden | |||
//| EXT_Erweiterung vorhanden | |||
MultiARBSup, MultiEXTSup: Boolean; | |||
//Liste der Integer Attribute | |||
IAttrib: array[0..22] of GLint; | |||
//Liste der Float Attribute (nur 0, da kein Wert) | |||
FAttrib: GLFloat; | |||
QueryAtrib, i: Integer; | |||
PPosiblePF, PSample: PglInt; | |||
begin | |||
//Pixelformate mit AA auslesen | |||
MultiARBSup := false; | |||
MultiEXTSup := false; | |||
if WGL_ARB_extensions_string and | |||
WGL_ARB_pixel_format and | |||
(WGL_ARB_MULTISAMPLE or GL_ARB_MULTISAMPLE) then | |||
multiARBSup := true; | |||
if WGL_EXT_extensions_string and | |||
WGL_EXT_pixel_format and | |||
(WGL_EXT_MULTISAMPLE or GL_EXT_MULTISAMPLE) then | |||
multiEXTSup := true; | |||
if multiARBSup then | |||
Read_WGL_ARB_pixel_format | |||
else if multiEXTSup then | |||
Read_WGL_EXT_pixel_format; | |||
if not (MultiARBSup or MultiEXTSup) then | |||
exit; | |||
IAttrib[00] := WGL_DRAW_TO_WINDOW_ARB; | |||
IAttrib[01] := 1; | |||
IAttrib[02] := WGL_SUPPORT_OPENGL_ARB; | |||
IAttrib[03] := 1; | |||
IAttrib[04] := WGL_DOUBLE_BUFFER_ARB; | |||
if (fPixelFormatSettings.DoubleBuffered) then | |||
IAttrib[05] := 1 | |||
else | |||
IAttrib[05] := 0; | |||
IAttrib[06] := WGL_PIXEL_TYPE_ARB; | |||
IAttrib[07] := WGL_TYPE_RGBA_ARB; | |||
IAttrib[08] := WGL_COLOR_BITS_ARB; | |||
IAttrib[09] := fPixelFormatSettings.ColorBits; | |||
IAttrib[10] := WGL_ALPHA_BITS_ARB; | |||
IAttrib[11] := 0; //TODO: fPixelFormatSettings.AlphaBits; | |||
IAttrib[12] := WGL_DEPTH_BITS_ARB; | |||
IAttrib[13] := fPixelFormatSettings.DepthBits; | |||
IAttrib[14] := WGL_STENCIL_BITS_ARB; | |||
IAttrib[15] := fPixelFormatSettings.StencilBits; | |||
IAttrib[16] := WGL_ACCUM_BITS_ARB; | |||
IAttrib[17] := fPixelFormatSettings.AccumBits; | |||
IAttrib[18] := WGL_AUX_BUFFERS_ARB; | |||
IAttrib[19] := fPixelFormatSettings.AuxBuffers; | |||
IAttrib[20] := WGL_SAMPLE_BUFFERS_ARB; | |||
IAttrib[21] := 1; | |||
IAttrib[22] := 0; | |||
FAttrib := 0; | |||
if multiARBSup then | |||
wglChoosePixelFormatARB(tmpContext.FDC, @IAttrib[0], @FAttrib, MaxCount, pPFList, @Count) | |||
else if multiEXTSup then | |||
wglChoosePixelFormatEXT(tmpContext.FDC, @IAttrib[0], @FAttrib, MaxCount, pPFList, @Count); | |||
if Count > length(PFList) then | |||
Count := length(PFList); | |||
QueryAtrib := WGL_SAMPLES_ARB; | |||
PSample := pSampleList; | |||
PPosiblePF := @PFList[0]; | |||
for i := 0 to Count-1 do begin | |||
if multiARBSup then | |||
wglGetPixelFormatAttribivARB(tmpContext.FDC, PPosiblePF^, 0, 1, @QueryAtrib, PSample) | |||
else if multiEXTSup then | |||
wglGetPixelFormatAttribivEXT(tmpContext.FDC, PPosiblePF^, 0, 1, @QueryAtrib, PSample); | |||
inc(PSample); | |||
inc(PPosiblePF); | |||
end; | |||
end; | |||
begin | |||
if (fPixelFormatSettings.MultiSampling = 1) then begin | |||
Result := FindPixelFormatNoAA; | |||
exit; | |||
end; | |||
Result := 0; | |||
OldDC := wglGetCurrentDC(); | |||
OldRC := wglGetCurrentContext(); | |||
try | |||
tmpWnd := TForm.Create(nil); | |||
tmpContext := TglcContextWGL.Create(tmpWnd); | |||
try | |||
pf := tmpContext.FindPixelFormatNoAA; | |||
tmpContext.OpenFromPF(pf); | |||
tmpContext.Activate; | |||
FillChar({%H-}PFList[0], Length(PFList), 0); | |||
FillChar({%H-}SampleList[0], Length(SampleList), 0); | |||
ChoosePF(@PFList[0], @SampleList[0], length(SampleList)); | |||
max := 0; | |||
for i := 0 to Count-1 do begin | |||
if (max < SampleList[i]) and (SampleList[i] <= fPixelFormatSettings.MultiSampling) and (PFList[i] <> 0) then begin | |||
max := SampleList[i]; | |||
result := PFList[i]; | |||
if (max = fPixelFormatSettings.MultiSampling) then | |||
break; | |||
end; | |||
end; | |||
tmpContext.Deactivate; | |||
finally | |||
FreeAndNil(tmpContext); | |||
FreeAndNil(tmpWnd); | |||
end; | |||
finally | |||
if (OldDC <> 0) and (OldRC <> 0) then | |||
ActivateRenderingContext(OldDC, OldRC); | |||
end; | |||
end; | |||
function TglcContextWGL.FindPixelFormatNoAA: Integer; | |||
const | |||
MemoryDCs = [OBJ_MEMDC, OBJ_METADC, OBJ_ENHMETADC]; | |||
var | |||
//DeviceContext | |||
DC: HDC; | |||
//Objekttyp des DCs | |||
AType: DWord; | |||
//Beschreibung zum passenden Pixelformat | |||
PFDescriptor: TPixelFormatDescriptor; | |||
begin | |||
result := 0; | |||
DC := GetDC(fHandle); | |||
if DC = 0 then begin | |||
exit; | |||
end; | |||
FillChar(PFDescriptor{%H-}, SizeOf(PFDescriptor), #0); | |||
with PFDescriptor do begin | |||
nSize := SizeOf(PFDescriptor); | |||
nVersion := 1; | |||
dwFlags := PFD_SUPPORT_OPENGL; | |||
AType := GetObjectType(DC); | |||
if AType = 0 then begin | |||
exit; | |||
end; | |||
if fPixelFormatSettings.DoubleBuffered then | |||
dwFlags := dwFlags or PFD_DOUBLEBUFFER; | |||
if fPixelFormatSettings.Stereo then | |||
dwFlags := dwFlags or PFD_STEREO; | |||
if AType in MemoryDCs then | |||
dwFlags := dwFlags or PFD_DRAW_TO_BITMAP | |||
else | |||
dwFlags := dwFlags or PFD_DRAW_TO_WINDOW; | |||
iPixelType := PFD_TYPE_RGBA; | |||
cColorBits := fPixelFormatSettings.ColorBits; | |||
//TODO: cAlphaBits := fPixelFormatSettings.AlphaBits; | |||
cDepthBits := fPixelFormatSettings.DepthBits; | |||
cStencilBits := fPixelFormatSettings.StencilBits; | |||
cAccumBits := fPixelFormatSettings.AccumBits; | |||
cAuxBuffers := fPixelFormatSettings.AuxBuffers; | |||
if fPixelFormatSettings.Layer = 0 then | |||
iLayerType := PFD_MAIN_PLANE | |||
else if fPixelFormatSettings.Layer > 0 then | |||
iLayerType := PFD_OVERLAY_PLANE | |||
else | |||
iLayerType := Byte(PFD_UNDERLAY_PLANE); | |||
end; | |||
result := ChoosePixelFormat(DC, @PFDescriptor); | |||
end; | |||
procedure TglcContextWGL.OpenFromPF(PixelFormat: Integer); | |||
var | |||
tmpRC: HGLRC; | |||
Attribs: array of GLint; | |||
CreateContextAttribs: TwglCreateContextAttribsARB; | |||
begin | |||
if PixelFormat = 0 then begin | |||
raise EWGLError.Create('Invalid PixelFormat'); | |||
end; | |||
FDC := GetDC(fHandle); | |||
if FDC = 0 then begin | |||
raise EWGLError.CreateFmt('Cannot create DC on %x',[fHandle]); | |||
end; | |||
if not SetPixelFormat(FDC, PixelFormat, nil) then begin | |||
ReleaseDC(fHandle, FDC); | |||
raise EWGLError.CreateFmt('Cannot set PF %d on Control %x DC %d',[PixelFormat, fHandle, FDC]); | |||
end; | |||
tmpRC := wglCreateContext(FDC); | |||
if tmpRC = 0 then begin | |||
ReleaseDC(fHandle, FDC); | |||
raise EWGLError.CreateFmt('Cannot create context on Control %x DC %d',[PixelFormat, fHandle, FDC]); | |||
end; | |||
if fUseVersion and | |||
(fVersionSettings.Major <> GLC_CONTEXT_VERSION_UNKNOWN) and | |||
(fVersionSettings.Minor <> GLC_CONTEXT_VERSION_UNKNOWN) then | |||
begin | |||
{ Code from dglOpenGL.pas (modified) } | |||
wglMakeCurrent(FDC, tmpRC); | |||
// Set attributes to describe our requested context | |||
SetLength(Attribs, 5); | |||
Attribs[0] := WGL_CONTEXT_MAJOR_VERSION_ARB; | |||
Attribs[1] := fVersionSettings.Major; | |||
Attribs[2] := WGL_CONTEXT_MINOR_VERSION_ARB; | |||
Attribs[3] := fVersionSettings.Minor; | |||
// Add context flag for forward compatible context | |||
// Forward compatible means no more support for legacy functions like | |||
// immediate mode (glvertex, glrotate, gltranslate, etc.) | |||
if fVersionSettings.ForwardCompatible then begin | |||
SetLength(Attribs, Length(Attribs)+2); | |||
Attribs[4] := WGL_CONTEXT_FLAGS_ARB; | |||
Attribs[5] := WGL_CONTEXT_FORWARD_COMPATIBLE_BIT_ARB; | |||
end; | |||
// Attribute flags must be finalized with a zero | |||
Attribs[High(Attribs)] := 0; | |||
// Get function pointer for new context creation function | |||
CreateContextAttribs := TwglCreateContextAttribsARB(wglGetProcAddress('wglCreateContextAttribsARB')); | |||
if not Assigned(CreateContextAttribs) then begin | |||
wglMakeCurrent(0, 0); | |||
wglDeleteContext(tmpRC); | |||
ReleaseDC(fHandle, FDC); | |||
raise Exception.Create('Could not get function pointer adress for wglCreateContextAttribsARB - OpenGL 3.x and above not supported!'); | |||
end; | |||
// Create context | |||
FRC := CreateContextAttribs(FDC, 0, @Attribs[0]); | |||
if (FRC = 0) then begin | |||
wglMakeCurrent(0, 0); | |||
wglDeleteContext(tmpRC); | |||
ReleaseDC(fHandle, FDC); | |||
raise Exception.Create('Could not create the desired OpenGL rendering context!'); | |||
end; | |||
wglMakeCurrent(0, 0); | |||
wglDeleteContext(tmpRC); | |||
end else | |||
FRC := tmpRC; | |||
end; | |||
constructor TglcContextWGL.Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings); | |||
begin | |||
inherited Create(aControl, aPixelFormatSettings); | |||
fHandle := aControl.Handle; | |||
UpdatePixelFormat; | |||
end; | |||
constructor TglcContextWGL.Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings; const aVersionSettings: TglcContextVersionSettings); | |||
begin | |||
inherited Create(aControl, aPixelFormatSettings, aVersionSettings); | |||
fHandle := aControl.Handle; | |||
UpdatePixelFormat; | |||
end; | |||
procedure TglcContextWGL.CloseContext; | |||
begin | |||
if (FRC <> 0) then begin | |||
Deactivate; | |||
DestroyRenderingContext(FRC); | |||
ReleaseDC(fHandle, FDC); | |||
FRC := 0; | |||
FDC := 0; | |||
end; | |||
end; | |||
procedure TglcContextWGL.Activate; | |||
begin | |||
ActivateRenderingContext(FDC, FRC); | |||
end; | |||
procedure TglcContextWGL.Deactivate; | |||
begin | |||
if wglGetCurrentContext()=FRC then | |||
DeactivateRenderingContext; | |||
end; | |||
function TglcContextWGL.IsActive: boolean; | |||
begin | |||
Result:= (FRC <> 0) and | |||
(FRC = wglGetCurrentContext()) and | |||
(FDC = wglGetCurrentDC()); | |||
end; | |||
procedure TglcContextWGL.SwapBuffers; | |||
begin | |||
Windows.SwapBuffers(FDC); | |||
end; | |||
procedure TglcContextWGL.SetSwapInterval(const aInterval: GLint); | |||
begin | |||
wglSwapIntervalEXT(aInterval); | |||
end; | |||
function TglcContextWGL.GetSwapInterval: GLint; | |||
begin | |||
result := wglGetSwapIntervalEXT(); | |||
end; | |||
procedure TglcContextWGL.Share(const aContext: TglcContext); | |||
begin | |||
wglShareLists(FRC, (aContext as TglcContextWGL).FRC); | |||
end; | |||
class function TglcContextWGL.ChangeDisplaySettings(const aWidth, aHeight, | |||
aBitPerPixel, aFreq: Integer; const aFlags: TglcDisplayFlags): Boolean; | |||
var | |||
dm: TDeviceMode; | |||
flags: Cardinal; | |||
begin | |||
FillChar(dm{%H-}, SizeOf(dm), 0); | |||
with dm do begin | |||
dmSize := SizeOf(dm); | |||
dmPelsWidth := aWidth; | |||
dmPelsHeight := aHeight; | |||
dmDisplayFrequency := aFreq; | |||
dmBitsPerPel := aBitPerPixel; | |||
dmFields := DM_PELSWIDTH or DM_PELSHEIGHT or DM_BITSPERPEL or DM_DISPLAYFREQUENCY; | |||
end; | |||
flags := 0; //CDS_TEST; | |||
if (dfFullscreen in aFlags) then | |||
flags := flags or CDS_FULLSCREEN; | |||
result := (Windows.ChangeDisplaySettings(dm, flags) = DISP_CHANGE_SUCCESSFUL); | |||
end; | |||
class function TglcContextWGL.IsAnyContextActive: boolean; | |||
begin | |||
Result:= (wglGetCurrentContext()<>0) and (wglGetCurrentDC()<>0); | |||
end; | |||
end. | |||