mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-10-31 03:01:28 +01:00
343 lines
10 KiB
ObjectPascal
343 lines
10 KiB
ObjectPascal
{
|
|
*****************************************************************************
|
|
See the file COPYING.modifiedLGPL.txt, included in this distribution,
|
|
for details about the license.
|
|
*****************************************************************************
|
|
|
|
Author: Mattias Gaertner
|
|
|
|
ToDo: MultiSampling, AuxBuffers
|
|
}
|
|
unit GLCarbonAGLContext;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, LCLProc, LCLType, gl, Forms,
|
|
MacOSAll,
|
|
AGL, CarbonProc, CarbonDef, CarbonPrivate,
|
|
WSLCLClasses, CarbonUtils,
|
|
Controls;
|
|
|
|
procedure LOpenGLViewport(Handle: HWND; Left, Top, Width, Height: integer);
|
|
procedure LOpenGLSwapBuffers(Handle: HWND);
|
|
function LOpenGLMakeCurrent(Handle: HWND): boolean;
|
|
function LOpenGLReleaseContext(Handle: HWND): boolean;
|
|
procedure LOpenGLClip(Handle: HWND);
|
|
function LOpenGLCreateContext(AWinControl: TWinControl;
|
|
{%H-}WSPrivate: TWSPrivateClass; SharedControl: TWinControl;
|
|
DoubleBuffered, RGBA: boolean;
|
|
const RedBits, GreenBits, BlueBits: Cardinal;
|
|
const MultiSampling, AlphaBits, DepthBits, StencilBits, AUXBuffers: Cardinal;
|
|
const {%H-}AParams: TCreateParams): HWND;
|
|
procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl);
|
|
function CreateOpenGLContextAttrList(DoubleBuffered: boolean; RGBA: boolean;
|
|
RedBits, GreenBits, BlueBits, MultiSampling, AlphaBits, DepthBits,
|
|
StencilBits, AUXBuffers: cardinal): PInteger;
|
|
|
|
|
|
type
|
|
TAGLControlInfo = record
|
|
Control: ControlRef;
|
|
WinControl: TWinControl;
|
|
AGLContext: TAGLContext;
|
|
end;
|
|
PAGLControlInfo = ^TAGLControlInfo;
|
|
|
|
var
|
|
AGLControlInfo_FOURCC: FourCharCode;
|
|
|
|
function CreateAGLControlInfo(Control: ControlRef; AGLContext: TAGLContext;
|
|
WinControl: TWinControl): PAGLControlInfo;
|
|
function GetAGLControlInfo(Control: ControlRef): PAGLControlInfo;
|
|
procedure FreeAGLControlInfo(Control: ControlRef);
|
|
function GetAGLContext(Control: ControlRef): TAGLContext;
|
|
|
|
implementation
|
|
|
|
procedure LOpenGLViewport(Handle: HWND; Left, Top, Width, Height: integer);
|
|
begin
|
|
glViewport(Left,Top,Width,Height);
|
|
end;
|
|
|
|
procedure LOpenGLSwapBuffers(Handle: HWND);
|
|
var
|
|
AGLContext: TAGLContext;
|
|
begin
|
|
AGLContext:=GetAGLContext({%H-}ControlRef(Handle));
|
|
aglSwapBuffers(AGLContext);
|
|
end;
|
|
|
|
function LOpenGLMakeCurrent(Handle: HWND): boolean;
|
|
var
|
|
AGLContext: TAGLContext;
|
|
Info: PAGLControlInfo;
|
|
Control: TCarbonCustomControl;
|
|
begin
|
|
Control:=TCarbonCustomControl(Handle);
|
|
Info:=GetAGLControlInfo(Control.Widget);
|
|
if Info=nil then exit;
|
|
AGLContext:=Info^.AGLContext;
|
|
Result:=aglSetCurrentContext(AGLContext)<>0;
|
|
end;
|
|
|
|
function LOpenGLReleaseContext(Handle: HWND): boolean;
|
|
begin
|
|
Result := aglSetCurrentContext(nil)<>GL_FALSE;
|
|
end;
|
|
|
|
procedure LOpenGLClip(Handle: HWND);
|
|
var
|
|
AGLContext: TAGLContext;
|
|
Info: PAGLControlInfo;
|
|
Form: TCustomForm;
|
|
Win: WindowRef;
|
|
//b: Rect;
|
|
clipRgn: RgnHandle;
|
|
Control: TCarbonCustomControl;
|
|
begin
|
|
Control:=TCarbonCustomControl(Handle);
|
|
Info:=GetAGLControlInfo(Control.Widget);
|
|
debugln(['LOpenGLMakeCurrent got ingo...']);
|
|
if Info=nil then exit;
|
|
AGLContext:=Info^.AGLContext;
|
|
aglSetCurrentContext(AGLContext);
|
|
debugln(['LOpenGLMakeCurrent set current ',dbgs(Handle)]);
|
|
Form:=GetParentForm(Info^.WinControl);
|
|
debugln(['LOpenGLMakeCurrent got parent form: ',DbgSName(Form)]);
|
|
Win:=TCarbonWindow(Form.Handle).Window;
|
|
|
|
debugln(['LOpenGLMakeCurrent set clipping ...']);
|
|
//GetWindowPortBounds(Win,b);
|
|
clipRgn:=NewRgn;
|
|
SetRectRgn(clipRgn,10,10,100,100);
|
|
aglSetInteger({%H-}TAGLContext(GetWRefCon(Win)),AGL_CLIP_REGION,clipRgn);
|
|
aglEnable({%H-}TAGLContext(GetWRefCon(Win)),AGL_CLIP_REGION);
|
|
DisposeRgn(clipRgn);
|
|
end;
|
|
|
|
procedure ResizeOGLControl(AWidget: TCarbonWidget);
|
|
var
|
|
info : PAGLControlInfo;
|
|
r : array [0..3] of Integer;
|
|
bnd : HIRect;
|
|
str : MacOSAll.Rect;
|
|
win : WindowRef;
|
|
begin
|
|
info:=GetAGLControlInfo(AWidget.Widget);
|
|
if not Assigned(info) then Exit;
|
|
win:=HIViewGetWindow(AWidget.Widget);
|
|
if not Assigned(win) then Exit;
|
|
GetWindowBounds(win, kWindowStructureRgn, str{%H-});
|
|
HIViewGetBounds(AWidget.Widget, bnd{%H-});
|
|
HIViewConvertPoint(bnd.origin, AWidget.Widget, nil);
|
|
|
|
r[0]:=Round(bnd.origin.x);
|
|
r[1]:=Round((str.bottom-str.top)- bnd.origin.y-bnd.size.height);
|
|
r[2]:=Round(bnd.size.width);
|
|
r[3]:=Round(bnd.size.height);
|
|
|
|
aglEnable(info^.aglContext, AGL_BUFFER_RECT);
|
|
aglSetInteger(info^.aglContext, AGL_BUFFER_RECT, @r[0]);
|
|
end;
|
|
|
|
function CarbonGLControl_Resize(ANextHandler: EventHandlerCallRef;
|
|
AEvent: EventRef;
|
|
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
|
|
begin
|
|
Result:=CallNextEventHandler(ANextHandler, AEvent);
|
|
ResizeOGLControl(AWidget);
|
|
end;
|
|
|
|
function CarbonGLControl_WindowChange(ANextHandler: EventHandlerCallRef;
|
|
AEvent: EventRef;
|
|
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
|
|
var
|
|
win : WindowRef;
|
|
begin
|
|
Result:=CallNextEventHandler(ANextHandler, AEvent);
|
|
if GetEventParameter(AEvent, kEventParamControlCurrentOwningWindow, typeWindowRef,
|
|
nil, sizeof(win), nil, @win) = noErr then
|
|
if Assigned(win) then ResizeOGLControl(AWidget);
|
|
end;
|
|
|
|
function LOpenGLCreateContext(AWinControl: TWinControl;
|
|
WSPrivate: TWSPrivateClass; SharedControl: TWinControl;
|
|
DoubleBuffered, RGBA: boolean;
|
|
const RedBits, GreenBits, BlueBits: Cardinal;
|
|
const MultiSampling, AlphaBits, DepthBits, StencilBits, AUXBuffers: Cardinal;
|
|
const AParams: TCreateParams): HWND;
|
|
var
|
|
disp: GDHandle;
|
|
aglPixFmt: TAGLPixelFormat;
|
|
aglContext: TAGLContext;
|
|
Control: TCarbonCustomControl;
|
|
AttrList: PInteger;
|
|
C: TCreateParams;
|
|
AGLInfo: PAGLControlInfo;
|
|
TempSpec: EventTypeSpec;
|
|
begin
|
|
Result:=0;
|
|
if AWinControl.Parent=nil then
|
|
RaiseGDBException('GLCarbonAGLContext.LOpenGLCreateContext no parent');
|
|
|
|
C.X := AWinControl.Left;
|
|
C.Y := AWinControl.Top;
|
|
C.Width := AWinControl.Width;
|
|
C.Height := AWinControl.Height;
|
|
// create a custom control
|
|
Control := TCarbonCustomControl.Create(AWinControl, C);
|
|
//debugln(['LOpenGLCreateContext ',dbgsName(AWinControl)]);
|
|
|
|
// create the AGL context
|
|
disp := GetMainDevice ();
|
|
AttrList:=CreateOpenGLContextAttrList(DoubleBuffered,RGBA,
|
|
RedBits,GreenBits,BlueBits,
|
|
MultiSampling,AlphaBits,DepthBits,StencilBits,AUXBuffers);
|
|
aglPixFmt := aglChoosePixelFormat (@disp, 1, AttrList);
|
|
System.FreeMem(AttrList);
|
|
aglContext := aglCreateContext (aglPixFmt, NIL);
|
|
aglDestroyPixelFormat(aglPixFmt);
|
|
|
|
aglSetDrawable(aglContext,
|
|
GetWindowPort(TCarbonWindow(GetParentForm(AWinControl).Handle).Window));
|
|
AGLControlInfo_FOURCC := MakeFourCC('ACI ');
|
|
|
|
AGLInfo:=CreateAGLControlInfo(Control.Widget, AGLContext, AWinControl);
|
|
if AGLInfo<>GetAGLControlInfo(Control.Widget) then
|
|
RaiseGDBException('GLCarbonAGLContext.LOpenGLCreateContext inconsistency');
|
|
|
|
ResizeOGLControl(Control);
|
|
TempSpec:=MakeEventSpec(kEventClassControl, kEventControlBoundsChanged);
|
|
InstallControlEventHandler(Control.Widget, RegisterEventHandler(@CarbonGLControl_Resize),
|
|
1, @TempSpec, Control, nil);
|
|
TempSpec:=MakeEventSpec(kEventClassControl, kEventControlOwningWindowChanged);
|
|
// The control might be embeded into a window after its creation.
|
|
// See example for this in bug report #17244
|
|
InstallControlEventHandler(Control.Widget, RegisterEventHandler(@CarbonGLControl_WindowChange),
|
|
1, @TempSpec, Control, nil);
|
|
|
|
Result:=HWnd(Control);
|
|
//debugln(['LOpenGLCreateContext ',dbgs(Result)]);
|
|
end;
|
|
|
|
procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl);
|
|
var
|
|
Ref: ControlRef;
|
|
Info: PAGLControlInfo;
|
|
begin
|
|
if not AWinControl.HandleAllocated then Exit;
|
|
if csDesigning in AWinControl.ComponentState then Exit;
|
|
Ref := ControlRef(TCarbonControl(AWinControl.Handle).Widget);
|
|
Info := GetAGLControlInfo(Ref);
|
|
if Info=nil then exit;
|
|
aglDestroyContext(Info^.AGLContext);
|
|
Info^.AGLContext := nil;
|
|
FreeAGLControlInfo(Ref);
|
|
end;
|
|
|
|
function CreateOpenGLContextAttrList(DoubleBuffered: boolean; RGBA: boolean;
|
|
RedBits, GreenBits, BlueBits, MultiSampling, AlphaBits, DepthBits,
|
|
StencilBits, AUXBuffers: cardinal): PInteger;
|
|
var
|
|
p: integer;
|
|
|
|
procedure Add(i: integer);
|
|
begin
|
|
if Result<>nil then
|
|
Result[p]:=i;
|
|
inc(p);
|
|
end;
|
|
|
|
procedure CreateList;
|
|
begin
|
|
Add(AGL_WINDOW);
|
|
if DoubleBuffered then
|
|
Add(AGL_DOUBLEBUFFER);
|
|
if RGBA then
|
|
Add(AGL_RGBA);
|
|
Add(AGL_NO_RECOVERY);
|
|
Add(AGL_MAXIMUM_POLICY);
|
|
Add(AGL_SINGLE_RENDERER);
|
|
Add(AGL_RED_SIZE); Add(RedBits);
|
|
Add(AGL_GREEN_SIZE); Add(GreenBits);
|
|
Add(AGL_BLUE_SIZE); Add(BlueBits);
|
|
if AlphaBits>0 then
|
|
begin
|
|
Add(AGL_ALPHA_SIZE); Add(AlphaBits);
|
|
end;
|
|
if DepthBits>0 then
|
|
begin
|
|
Add(AGL_DEPTH_SIZE); Add(DepthBits);
|
|
end;
|
|
if StencilBits>0 then
|
|
begin
|
|
Add(AGL_STENCIL_SIZE); Add(StencilBits);
|
|
end;
|
|
if AUXBuffers>0 then
|
|
begin
|
|
Add(AGL_AUX_BUFFERS); Add(AUXBuffers);
|
|
end;
|
|
if MultiSampling > 1 then
|
|
begin
|
|
Add(AGL_SAMPLE_BUFFERS_ARB); Add(1);
|
|
Add(AGL_SAMPLES_ARB); Add(MultiSampling);
|
|
end;
|
|
|
|
Add(AGL_NONE);
|
|
end;
|
|
|
|
begin
|
|
Result:=nil;
|
|
p:=0;
|
|
CreateList;
|
|
GetMem(Result,SizeOf(integer)*p);
|
|
p:=0;
|
|
CreateList;
|
|
end;
|
|
|
|
function CreateAGLControlInfo(Control: ControlRef; AGLContext: TAGLContext;
|
|
WinControl: TWinControl): PAGLControlInfo;
|
|
begin
|
|
New(Result);
|
|
FillByte(Result^, SizeOf(Result^), 0);
|
|
Result^.Control:=Control;
|
|
Result^.WinControl:=WinControl;
|
|
Result^.AGLContext:=AGLContext;
|
|
|
|
SetControlProperty(Control, LAZARUS_FOURCC, AGLControlInfo_FOURCC,
|
|
SizeOf(Result), @Result);
|
|
end;
|
|
|
|
function GetAGLControlInfo(Control: ControlRef): PAGLControlInfo;
|
|
var
|
|
m: LongWord;
|
|
begin
|
|
GetControlProperty(Control, LAZARUS_FOURCC, AGLControlInfo_FOURCC,
|
|
SizeOf(Result), @m, @Result);
|
|
end;
|
|
|
|
procedure FreeAGLControlInfo(Control: ControlRef);
|
|
var
|
|
Info: PAGLControlInfo;
|
|
begin
|
|
Info:=GetAGLControlInfo(Control);
|
|
if Info=nil then exit;
|
|
RemoveControlProperty(Control, LAZARUS_FOURCC, AGLControlInfo_FOURCC);
|
|
System.FreeMem(Info);
|
|
end;
|
|
|
|
function GetAGLContext(Control: ControlRef): TAGLContext;
|
|
begin
|
|
Result:=GetAGLControlInfo(TCarbonCustomControl(Control).Widget)^.AGLContext;
|
|
end;
|
|
|
|
initialization
|
|
|
|
finalization
|
|
|
|
end.
|
|
|