mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-08 08:52:34 +02:00
375 lines
10 KiB
ObjectPascal
375 lines
10 KiB
ObjectPascal
{
|
|
*****************************************************************************
|
|
* *
|
|
* See the file COPYING.modifiedLGPL, included in this distribution, *
|
|
* for details about the copyright. *
|
|
* *
|
|
* This program is distributed in the hope that it will be useful, *
|
|
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
|
|
* *
|
|
*****************************************************************************
|
|
|
|
Author: Mattias Gaertner
|
|
|
|
}
|
|
unit GTKGLAreaControl;
|
|
|
|
{$MODE objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, {$IFDEF VER1_0}Linux{$ELSE}Unix{$ENDIF}, Forms,
|
|
Controls, Graphics, LMessages, VCLGlobals, InterfaceBase, GTKInt,
|
|
WSLCLClasses, WSControls, LResources,
|
|
GLib, Gtk, NVGL, GTKGLArea_Int;
|
|
|
|
type
|
|
TGtkGlAreaMakeCurrentEvent = procedure(Sender: TObject;
|
|
var Allow: boolean) of object;
|
|
|
|
{ TCustomGTKGLAreaControl }
|
|
|
|
TCustomGTKGLAreaControl = class(TWinControl)
|
|
private
|
|
FCanvas: TCanvas; // only valid at designtime
|
|
FOnMakeCurrent: TGtkGlAreaMakeCurrentEvent;
|
|
FOnPaint: TNotifyEvent;
|
|
FCurrentFrameTime: integer; // in msec
|
|
FLastFrameTime: integer; // in msec
|
|
FFrameDiffTime: integer; // in msec
|
|
FSharedArea: TCustomGTKGLAreaControl;
|
|
FSharingAreas: TList;
|
|
function GetSharingAreas(Index: integer): TCustomGTKGLAreaControl;
|
|
procedure SetSharedArea(const AValue: TCustomGTKGLAreaControl);
|
|
protected
|
|
procedure WMPaint(var Message: TLMPaint); message LM_PAINT;
|
|
function GetWidget: PGtkGLArea;
|
|
procedure UpdateFrameTimeDiff;
|
|
public
|
|
constructor Create(TheOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
Procedure Paint; virtual;
|
|
procedure DoOnResize; override;
|
|
procedure DoOnPaint; virtual;
|
|
procedure SwapBuffers; virtual;
|
|
function MakeCurrent: integer; virtual;
|
|
function RestoreOldGtkGLAreaControl: boolean;
|
|
function SharingAreasCount: integer;
|
|
property SharingAreas[Index: integer]: TCustomGTKGLAreaControl read GetSharingAreas;
|
|
public
|
|
property FrameDiffTimeInMSecs: integer read FFrameDiffTime;
|
|
property OnMakeCurrent: TGtkGlAreaMakeCurrentEvent read FOnMakeCurrent
|
|
write FOnMakeCurrent;
|
|
property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
|
|
property SharedArea: TCustomGTKGLAreaControl read FSharedArea write SetSharedArea;
|
|
property Widget: PGtkGLArea read GetWidget;
|
|
end;
|
|
|
|
|
|
{ TGTKGLAreaControl }
|
|
|
|
TGTKGLAreaControl = class(TCustomGTKGLAreaControl)
|
|
published
|
|
property Align;
|
|
property Anchors;
|
|
property Enabled;
|
|
property OnClick;
|
|
property OnConstrainedResize;
|
|
property OnDblClick;
|
|
property OnEnter;
|
|
property OnExit;
|
|
property OnKeyDown;
|
|
property OnKeyPress;
|
|
property OnKeyUp;
|
|
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 SharedArea;
|
|
property ShowHint;
|
|
property Visible;
|
|
end;
|
|
|
|
|
|
{ TWSGTKGLAreaControl }
|
|
|
|
TWSGTKGLAreaControl = class(TWSWinControl)
|
|
public
|
|
class function CreateHandle(const AComponent: TComponent;
|
|
const AParams: TCreateParams): THandle; override;
|
|
end;
|
|
|
|
|
|
function GetCurrentGtkGLAreaControl: TGTKGLAreaControl;
|
|
|
|
procedure Register;
|
|
|
|
implementation
|
|
|
|
const
|
|
InitAttrList: array [1..11] of LongInt = (
|
|
GDK_GL_RGBA,
|
|
GDK_GL_RED_SIZE, 1,
|
|
GDK_GL_GREEN_SIZE, 1,
|
|
GDK_GL_BLUE_SIZE, 1,
|
|
GDK_GL_DEPTH_SIZE,1,
|
|
GDK_GL_DOUBLEBUFFER,
|
|
GDK_GL_None
|
|
);
|
|
|
|
var
|
|
GtkGLAreaControlStack: TList;
|
|
|
|
function GetCurrentGtkGLAreaControl: TGTKGLAreaControl;
|
|
begin
|
|
if (GtkGLAreaControlStack<>nil)
|
|
and (GtkGLAreaControlStack.Count>0) then
|
|
Result:=TGTKGLAreaControl(GtkGLAreaControlStack[GtkGLAreaControlStack.Count-1])
|
|
else
|
|
Result:=nil;
|
|
end;
|
|
|
|
procedure Register;
|
|
begin
|
|
RegisterComponents('OpenGL',[TGTKGLAreaControl]);
|
|
end;
|
|
|
|
{ TCustomGTKGLAreaControl }
|
|
|
|
constructor TCustomGTKGLAreaControl.Create(TheOwner: TComponent);
|
|
begin
|
|
inherited Create(TheOwner);
|
|
ControlStyle:=ControlStyle-[csSetCaption];
|
|
if (csDesigning in ComponentState) then begin
|
|
FCanvas := TControlCanvas.Create;
|
|
TControlCanvas(FCanvas).Control := Self;
|
|
end else
|
|
FCompStyle:=csNonLCL;
|
|
SetInitialBounds(0, 0, 160, 90);
|
|
end;
|
|
|
|
destructor TCustomGTKGLAreaControl.Destroy;
|
|
begin
|
|
if FSharingAreas<>nil then begin
|
|
while SharingAreasCount>0 do
|
|
SharingAreas[SharingAreasCount-1].SharedArea:=nil;
|
|
FreeAndNil(FSharingAreas);
|
|
end;
|
|
SharedArea:=nil;
|
|
FCanvas.Free;
|
|
FCanvas:=nil;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TCustomGTKGLAreaControl.Paint;
|
|
begin
|
|
if (not (csDesigning in ComponentState))
|
|
and Enabled and Visible and HandleAllocated
|
|
and (gint(True) = MakeCurrent) then begin
|
|
try
|
|
UpdateFrameTimeDiff;
|
|
DoOnPaint;
|
|
finally
|
|
RestoreOldGtkGLAreaControl;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomGTKGLAreaControl.DoOnResize;
|
|
var
|
|
RestoreNeeded: Boolean;
|
|
begin
|
|
RestoreNeeded:=false;
|
|
if (not (csDesigning in ComponentState))
|
|
and Enabled and Visible and HandleAllocated
|
|
and (gint(True) = MakeCurrent) then begin
|
|
RestoreNeeded:=true;
|
|
glViewport (0, 0, Width, Height);
|
|
end;
|
|
try
|
|
inherited DoOnResize;
|
|
finally
|
|
if RestoreNeeded then
|
|
RestoreOldGtkGLAreaControl;
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomGTKGLAreaControl.DoOnPaint;
|
|
begin
|
|
if Assigned(OnPaint) then OnPaint(Self);
|
|
end;
|
|
|
|
procedure TCustomGTKGLAreaControl.SwapBuffers;
|
|
begin
|
|
gtk_gl_area_swap_buffers(Widget);
|
|
end;
|
|
|
|
function TCustomGTKGLAreaControl.MakeCurrent: integer;
|
|
var
|
|
Allowed: Boolean;
|
|
begin
|
|
if Assigned(FOnMakeCurrent) then begin
|
|
Allowed:=true;
|
|
OnMakeCurrent(Self,Allowed);
|
|
if not Allowed then begin
|
|
Result:=gint(False);
|
|
exit;
|
|
end;
|
|
end;
|
|
// make sure the widget is realized
|
|
gtk_widget_realize(PGtkWidget(Widget));
|
|
// make current
|
|
Result:=gtk_gl_area_make_current(Widget);
|
|
if Result=gint(True) then begin
|
|
// on success push on stack
|
|
if GtkGLAreaControlStack=nil then
|
|
GtkGLAreaControlStack:=TList.Create;
|
|
GtkGLAreaControlStack.Add(Self);
|
|
end;
|
|
end;
|
|
|
|
function TCustomGTKGLAreaControl.RestoreOldGtkGLAreaControl: boolean;
|
|
var
|
|
RestoredControl: TGTKGLAreaControl;
|
|
begin
|
|
Result:=false;
|
|
// check if the current context is on stack
|
|
if (GtkGLAreaControlStack=nil) or (GtkGLAreaControlStack.Count=0) then exit;
|
|
// pop
|
|
GtkGLAreaControlStack.Delete(GtkGLAreaControlStack.Count-1);
|
|
// make old control the current control
|
|
if GtkGLAreaControlStack.Count>0 then begin
|
|
RestoredControl:=
|
|
TGTKGLAreaControl(GtkGLAreaControlStack[GtkGLAreaControlStack.Count-1]);
|
|
if gtk_gl_area_make_current(RestoredControl.Widget)<>gint(true) then
|
|
exit;
|
|
end;
|
|
Result:=true;
|
|
end;
|
|
|
|
function TCustomGTKGLAreaControl.SharingAreasCount: integer;
|
|
begin
|
|
if FSharingAreas=nil then
|
|
Result:=0
|
|
else
|
|
Result:=FSharingAreas.Count;
|
|
end;
|
|
|
|
procedure TCustomGTKGLAreaControl.SetSharedArea(
|
|
const AValue: TCustomGTKGLAreaControl);
|
|
begin
|
|
if FSharedArea=AValue then exit;
|
|
if AValue=Self then
|
|
Raise Exception.Create('An area can not be shared by itself.');
|
|
// unshare old
|
|
if (AValue<>nil) and (AValue.SharedArea<>nil) then
|
|
Raise Exception.Create('Target area is sharing too. A sharing area can not be shared.');
|
|
if FSharedArea<>nil then FSharedArea.FSharingAreas.Remove(Self);
|
|
// share new
|
|
if (AValue<>nil) and (csDestroying in AValue.ComponentState) then
|
|
FSharedArea:=nil
|
|
else begin
|
|
FSharedArea:=AValue;
|
|
if (FSharedArea<>nil) then begin
|
|
if FSharedArea.FSharingAreas=nil then
|
|
FSharedArea.FSharingAreas:=TList.Create;
|
|
FSharedArea.FSharingAreas.Add(Self);
|
|
end;
|
|
end;
|
|
// recreate handle if needed
|
|
if HandleAllocated and (not (csDesigning in ComponentState)) then
|
|
ReCreateWnd;
|
|
end;
|
|
|
|
function TCustomGTKGLAreaControl.GetSharingAreas(Index: integer
|
|
): TCustomGTKGLAreaControl;
|
|
begin
|
|
Result:=TCustomGTKGLAreaControl(FSharingAreas[Index]);
|
|
end;
|
|
|
|
procedure TCustomGTKGLAreaControl.WMPaint(var Message: TLMPaint);
|
|
begin
|
|
Include(FControlState, csCustomPaint);
|
|
inherited WMPaint(Message);
|
|
if (csDesigning in ComponentState) and (FCanvas<>nil) then begin
|
|
with FCanvas do begin
|
|
Brush.Color:=clLtGray;
|
|
Pen.Color:=clRed;
|
|
Rectangle(0,0,Width-1,Height-1);
|
|
MoveTo(0,0);
|
|
LineTo(Width,Height);
|
|
MoveTo(0,Height);
|
|
LineTo(Width,0);
|
|
end;
|
|
end else begin
|
|
Paint;
|
|
end;
|
|
Exclude(FControlState, csCustomPaint);
|
|
end;
|
|
|
|
function TCustomGTKGLAreaControl.GetWidget: PGtkGLArea;
|
|
begin
|
|
if HandleAllocated then
|
|
Result:=PGtkGLArea(Handle)
|
|
else
|
|
Result:=nil;
|
|
end;
|
|
|
|
procedure TCustomGTKGLAreaControl.UpdateFrameTimeDiff;
|
|
var
|
|
hour, minutes, secs, msecs, usecs: word;
|
|
begin
|
|
GetTime(hour, minutes, secs, msecs, usecs);
|
|
FCurrentFrameTime:=(((minutes*60)+secs) * 1000)+msecs;
|
|
if FLastFrameTime=0 then
|
|
FLastFrameTime:=FCurrentFrameTime;
|
|
// calculate time since last call:
|
|
FFrameDiffTime:=FCurrentFrameTime-FLastFrameTime;
|
|
// if the hour changed, the minutes restarts:
|
|
if (FFrameDiffTime<0) then inc(FFrameDiffTime,60*60*1000);
|
|
FLastFrameTime:=FCurrentFrameTime;
|
|
end;
|
|
|
|
{ TWSGTKGLAreaControl }
|
|
|
|
function TWSGTKGLAreaControl.CreateHandle(const AComponent: TComponent;
|
|
const AParams: TCreateParams): THandle;
|
|
var
|
|
NewWidget: Pointer;
|
|
Area: TCustomGTKGLAreaControl;
|
|
begin
|
|
if csDesigning in AComponent.ComponentState then
|
|
Result:=inherited CreateHandle(AComponent,AParams)
|
|
else begin
|
|
Area:=AComponent as TCustomGTKGLAreaControl;
|
|
if (Area.SharedArea<>nil) and (not (csDestroying in Area.ComponentState))
|
|
then
|
|
NewWidget:=gtk_gl_area_share_new(Plongint(@InitAttrList),
|
|
Area.SharedArea.Widget)
|
|
else
|
|
NewWidget:=gtk_gl_area_new(Plongint(@InitAttrList));
|
|
Result:=longint(NewWidget);
|
|
TGTKWidgetSet(InterfaceObject).FinishComponentCreate(AComponent,NewWidget,true);
|
|
end;
|
|
end;
|
|
|
|
initialization
|
|
{$i gtkglarea.lrs}
|
|
GtkGLAreaControlStack:=nil;
|
|
RegisterWSComponent(TCustomGTKGLAreaControl,TWSGTKGLAreaControl);
|
|
|
|
finalization
|
|
FreeAndNil(GtkGLAreaControlStack);
|
|
|
|
end.
|