1 {
2  *****************************************************************************
3   See the file COPYING.modifiedLGPL.txt, included in this distribution,
4   for details about the license.
5  *****************************************************************************
6 
7   Author: Mattias Gaertner
8 
9   ToDo:
10     use custom pixelformat
11       attributes: doublebufferd, version, ...
12       It should work with initWithFrame_pixelFormat, but this paints nothing
13     SwapBuffers - there is no function like aglSwapBuffers in CGL/NS
14     Mouse:
15       the TLCLCommonCallback mouse handlers check Owner.isEnabled, which
16       for a NSView always returns false.
17     SharedControl
18 }
19 unit GLCocoaNSContext;
20 
21 {$mode objfpc}{$H+}
22 {$ModeSwitch objectivec1}
23 
24 interface
25 
26 uses
27   Classes, SysUtils, types, CocoaWSCommon, CocoaPrivate, CocoaUtils, LCLType, Cocoa_Extra,
28   LMessages, LCLMessageGlue,
29   Controls, LazLoggerBase, WSLCLClasses, MacOSAll, CocoaAll;
30 
LBackingScaleFactornull31 function LBackingScaleFactor(Handle: HWND): single;
32 procedure LSetWantsBestResolutionOpenGLSurface(const AValue: boolean; Handle: HWND);
33 procedure LOpenGLViewport(Handle: HWND; Left, Top, Width, Height: integer);
34 procedure LOpenGLSwapBuffers(Handle: HWND);
LOpenGLMakeCurrentnull35 function LOpenGLMakeCurrent(Handle: HWND): boolean;
LOpenGLReleaseContextnull36 function LOpenGLReleaseContext(Handle: HWND): boolean;
37 procedure LOpenGLClip(Handle: HWND);
LOpenGLCreateContextnull38 function LOpenGLCreateContext(AWinControl: TWinControl;
39               {%H-}WSPrivate: TWSPrivateClass; SharedControl: TWinControl;
40               DoubleBuffered, AMacRetinaMode: boolean;
41               MajorVersion, MinorVersion: Cardinal;
42               MultiSampling, AlphaBits, DepthBits, StencilBits, AUXBuffers: Cardinal;
43               const {%H-}AParams: TCreateParams): HWND;
44 procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl);
CreateOpenGLContextAttrListnull45 function CreateOpenGLContextAttrList(DoubleBuffered: boolean;
46               MajorVersion, MinorVersion: Cardinal;
47               MultiSampling, AlphaBits, DepthBits,
48               StencilBits, AUXBuffers: cardinal): NSOpenGLPixelFormatAttributePtr;
49 
50 const
51   // missing constants in FPC 3.1.1 rev 31197 and below
52   NSOpenGLPFAOpenGLProfile            = 99; //cr: name changed to match https://developer.apple.com/library/mac/documentation//Cocoa/Reference/ApplicationKit/Classes/NSOpenGLPixelFormat_Class/index.html
53   NSOpenGLProfileLegacy         = $1000;
54   NSOpenGLProfileVersion3_2Core = $3200;
55   NSOpenGLProfileVersion4_1Core = $4100; //requires OSX SDK 10.10 or later, https://github.com/google/gxui/issues/98
56 
57 type
58   NSOpenGLViewFix = objccategory external (NSOpenGLView)
59     procedure setWantsBestResolutionOpenGLSurface(bool: NSInteger); message 'setWantsBestResolutionOpenGLSurface:';
60   end;
61   NSScreenFix = objccategory external (NSScreen)
backingScaleFactornull62      function backingScaleFactor: CGFloat ; message 'backingScaleFactor';
63   end;
64 
65   { TCocoaOpenGLView }
66 
67   TCocoaOpenGLView = objcclass(NSOpenGLView)
68   public
69     Owner: TWinControl;
70     //nsGL: NSOpenGLContext;
71     callback: TLCLCommonCallback;
72     backingScaleFactor: Single;
acceptsFirstRespondernull73     function acceptsFirstResponder: LCLObjCBoolean; override;
becomeFirstRespondernull74     function becomeFirstResponder: LCLObjCBoolean; override;
resignFirstRespondernull75     function resignFirstResponder: LCLObjCBoolean; override;
76     procedure drawRect(dirtyRect: NSRect); override;
77     procedure dealloc; override;
lclGetCallbacknull78     function lclGetCallback: ICommonCallback; override;
79     procedure lclClearCallback; override;
lclIsEnablednull80     function lclIsEnabled: Boolean; override;
81     // mouse
82     procedure mouseDown(event: NSEvent); override;
83     procedure mouseUp(event: NSEvent); override;
84     procedure rightMouseDown(event: NSEvent); override;
85     procedure rightMouseUp(event: NSEvent); override;
86     procedure rightMouseDragged(event: NSEvent); override;
87     procedure otherMouseDown(event: NSEvent); override;
88     procedure otherMouseUp(event: NSEvent); override;
89     procedure otherMouseDragged(event: NSEvent); override;
90     procedure mouseDragged(event: NSEvent); override;
91     procedure mouseEntered(event: NSEvent); override;
92     procedure mouseExited(event: NSEvent); override;
93     procedure mouseMoved(event: NSEvent); override;
94     procedure scrollWheel(event: NSEvent); override;
95     // other
96     procedure resetCursorRects; override;
97   end;
98 
GetCGLContextObjnull99 function GetCGLContextObj(OpenGLControlHandle: HWND): CGLContextObj;
100 (*function CreateCGLContextAttrList(DoubleBuffered: boolean;
101               {$IFDEF UsesModernGL}
102               MajorVersion, MinorVersion: Cardinal;
103               {$ENDIF}
104               MultiSampling, AlphaBits, DepthBits,
105               StencilBits, AUXBuffers: cardinal): PInteger;
106 function IsCGLPixelFormatAvailable(Attribs: PInteger): boolean;*)
107 
108 implementation
109 
110 //value > 1 if screen is scaled, e.g. default for MOST retina displays is 2
LBackingScaleFactornull111 function LBackingScaleFactor(Handle: HWND): single;
112 begin
113   result := TCocoaOpenGLView(Handle).backingScaleFactor;
114 end;
115 
116 procedure LSetWantsBestResolutionOpenGLSurface(const AValue: boolean; Handle: HWND);
117 var
118   View: TCocoaOpenGLView;
119 begin
120   if Handle=0 then exit;
121   View:=TCocoaOpenGLView(Handle);
122   if not View.respondsToSelector(objcselector('setWantsBestResolutionOpenGLSurface:')) then exit;
123   if AValue then
124     View.setWantsBestResolutionOpenGLSurface(1)
125   else
126     View.setWantsBestResolutionOpenGLSurface(0);
127   if (AValue) and (NSScreen.mainScreen.respondsToSelector(objcselector('backingScaleFactor'))) then //MacOS >=10.7
128     View.backingScaleFactor := NSScreen.mainScreen.backingScaleFactor
129   else
130     View.backingScaleFactor := 1;
131 end;
132 
133 procedure LOpenGLViewport(Handle: HWND; Left, Top, Width, Height: integer);
134 var
135   View: NSOpenGLView absolute Handle;
136   lFinalWidth, lFinalHeight: Integer;
137 begin
138   lFinalWidth := Width;
139   lFinalHeight := Height;
140   if View <> nil then
141   begin
142     lFinalWidth := Round(Width * LBackingScaleFactor(Handle));
143     lFinalHeight := Round(Height * LBackingScaleFactor(Handle));
144   end;
145   glViewport(Left,Top,lFinalWidth,lFinalHeight);
146 end;
147 
148 procedure LOpenGLSwapBuffers(Handle: HWND);
149 //var
150 //  View: TCocoaOpenGLView;  //TCocoaOpenGLView
151 begin
152   if Handle=0 then exit;
153   glFlush();
154   // View:=TCocoaOpenGLView(Handle);
155   // View.nsGL.flushBuffer;
156 end;
157 
LOpenGLMakeCurrentnull158 function LOpenGLMakeCurrent(Handle: HWND): boolean;
159 var
160   CGLContext: CGLContextObj;
161 begin
162   if Handle=0 then exit(false);
163   CGLContext:=GetCGLContextObj(Handle);
164   Result:=CGLSetCurrentContext(CGLContext)=kCGLNoError;
165 end;
166 
LOpenGLReleaseContextnull167 function LOpenGLReleaseContext(Handle: HWND): boolean;
168 begin
169   if Handle=0 then exit(false);
170   Result:=CGLSetCurrentContext(nil)=kCGLNoError;
171   //Result:=true;
172 end;
173 
174 procedure LOpenGLClip(Handle: HWND);
175 begin
176   if Handle=0 then exit;
177   // ToDo
178 end;
179 
LOpenGLCreateContextnull180 function LOpenGLCreateContext(AWinControl: TWinControl;
181   WSPrivate: TWSPrivateClass; SharedControl: TWinControl;
182   DoubleBuffered, AMacRetinaMode: boolean;
183   MajorVersion, MinorVersion: Cardinal;
184   MultiSampling, AlphaBits, DepthBits, StencilBits,
185   AUXBuffers: Cardinal; const AParams: TCreateParams): HWND;
186 var
187   View: TCocoaOpenGLView;
188   Attrs: NSOpenGLPixelFormatAttributePtr;
189   PixFmt: NSOpenGLPixelFormat;
190   p: NSView;
191   ns: NSRect;
192   aNSOpenGLContext: NSOpenGLContext;
193   CGLContext: CGLContextObj;
194 begin
195   Result:=0;
196   p := nil;
197   if (AParams.WndParent <> 0) then
198     p := NSObject(AParams.WndParent).lclContentView;
199   if Assigned(p) then
200     LCLToNSRect(types.Bounds(AParams.X, AParams.Y, AParams.Width, AParams.Height),
201       p.frame.size.height, ns)
202   else
203     ns := GetNSRect(AParams.X, AParams.Y, AParams.Width, AParams.Height);
204   Attrs:=CreateOpenGLContextAttrList(DoubleBuffered,MajorVersion,MinorVersion, MultiSampling,AlphaBits,DepthBits,StencilBits,AUXBuffers);
205   try
206     PixFmt:=NSOpenGLPixelFormat(NSOpenGLPixelFormat.alloc).initWithAttributes(Attrs);
207     aNSOpenGLContext:=NSOpenGLContext(NSOpenGLContext.alloc).initWithFormat_shareContext(PixFmt,nil);
208     if aNSOpenGLContext  = nil then
209     	debugln(['LOpenGLCreateContext Error']);
210     View := TCocoaOpenGLView(TCocoaOpenGLView.alloc).initWithFrame_pixelFormat(ns,PixFmt);
211     if not Assigned(View) then Exit;
212   finally
213     FreeMem(Attrs);
214   end;
215   View.setHidden(AParams.Style and WS_VISIBLE = 0);
216   if Assigned(p) then
217     p.addSubview(View);
218   SetViewDefaults(View);
219   View.Owner:=AWinControl;
220   //View.nsGL := aNSOpenGLContext;
221   View.callback:=TLCLCommonCallback.Create(View, AWinControl);
222   LSetWantsBestResolutionOpenGLSurface(AMacRetinaMode, HWND(View));
223   //View.setPixelFormat(PixFmt);
224   Result:=TLCLIntfHandle(View);
225 end;
226 
227 procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl);
228 begin
229   // no special needed, simply release handle
230   if AWinControl=nil then
231     raise Exception.Create('');
232 end;
233 
CreateOpenGLContextAttrListnull234 function CreateOpenGLContextAttrList(DoubleBuffered: boolean; MajorVersion,
235   MinorVersion: Cardinal; MultiSampling, AlphaBits, DepthBits, StencilBits,
236   AUXBuffers: cardinal): NSOpenGLPixelFormatAttributePtr;
237 var
238   p: integer;
239 procedure AddUInt32(i: NSOpenGLPixelFormatAttribute);
240   begin
241     if Result<>nil then
242       Result[p]:=i;
243     inc(p);
244   end;
245 
246   procedure CreateList;
247   begin
248     //see https://developer.apple.com/library/mac/documentation//Cocoa/Reference/ApplicationKit/Classes/NSOpenGLPixelFormat_Class/index.html
249     //AddUInt32(NSOpenGLPFAAccelerated);  // <- comment out: we can run in software if hardware is not available
250     //AddUInt32(NSOpenGLPFAOpenGLProfile); //Versions beyond 'Legacy' appear to break CULL_FACE and DEPTH_BUFFER, legacy seems to be default, so comment out whole instruction
251     //if (MajorVersion>=4) and (MinorVersion>=1)
252     //  AddUInt32(NSOpenGLProfileVersion4_1Core);
253     //else if (MajorVersion>=3) and (MinorVersion>=2) then
254     //     AddUInt32(NSOpenGLProfileVersion3_2Core);
255     //else
256     //AddUInt32(NSOpenGLProfileLegacy); // NSOpenGLProfileLegacy is default and sufficient, later versions depend on SDK we are building against
257     AddUInt32(NSOpenGLPFAOpenGLProfile);
258     if (MajorVersion>=4) and (MinorVersion>=1) then
259        AddUInt32(NSOpenGLProfileVersion4_1Core) //OpenGL 4.1, GLSL 4.1
260     else if (MajorVersion>=3) and (MinorVersion>=2) then
261         AddUInt32(NSOpenGLProfileVersion3_2Core)
262     else
263         AddUInt32(NSOpenGLProfileLegacy); //OpenGL 2.1, GLSL 1.2
264     AddUInt32(NSOpenGLPFAColorSize); AddUInt32(24);
265     if DepthBits > 0 then begin
266        AddUInt32(NSOpenGLPFADepthSize);  AddUInt32(32);
267     end;
268     if AlphaBits>0 then begin
269       AddUInt32(NSOpenGLPFAAlphaSize);  AddUInt32(AlphaBits);
270     end;
271     AddUInt32(NSOpenGLPFAAccelerated);
272     if MultiSampling > 1 then begin
273       AddUInt32(NSOpenGLPFAMultisample);
274       AddUInt32(NSOpenGLPFASampleBuffers); AddUInt32(1);
275       AddUInt32(NSOpenGLPFASamples); AddUInt32(MultiSampling);
276     end;
277     if StencilBits>0 then
278     begin
279       AddUInt32(NSOpenGLPFAStencilSize);  AddUInt32(StencilBits);
280     end;
281     if AUXBuffers>0 then
282     begin
283       AddUInt32(NSOpenGLPFAAuxBuffers);  AddUInt32(AUXBuffers);
284     end;
285     //if DoubleBuffered then //requires fix for nsGL
286     //   AddUInt32(NSOpenGLPFADoubleBuffer); //this doen't work with Lazarus
287     AddUInt32(NSOpenGLPFAMaximumPolicy); //allows future changes to make attributes more demanding, e.g. add multisampling
288 
289 
290     AddUInt32(NSOpenGLPFANoRecovery); //see apple web page: "not generally useful" but might help with multisample
291     AddUInt32(0); // end of list
292   end;
293 
294 begin
295   Result:=nil;
296   p:=0;
297   CreateList;
298   GetMem(Result,SizeOf(NSOpenGLPixelFormatAttribute)*(p+1));
299   p:=0;
300   CreateList;
301 end;
302 
303 function GetCGLContextObj(OpenGLControlHandle: HWND): CGLContextObj;
304 var
305   View: NSOpenGLView;
306 begin
307   Result:=nil;
308   if OpenGLControlHandle=0 then exit;
309   View:=TCocoaOpenGLView(OpenGLControlHandle);
310   Result:=CGLContextObj(View.openGLContext.CGLContextObj);
311   NSScreen.mainScreen.colorSpace;
312 end;
313 
314 (*
315 //these functions are commented out: this was an attempt to use CGL, porting NSOpenGLView instead was more successful
316 function CreateCGLContextAttrList(DoubleBuffered: boolean; MultiSampling,
317   AlphaBits, DepthBits, StencilBits, AUXBuffers: cardinal): PInteger;
318 var
319   p: integer;
320 
321   procedure Add(i: integer);
322   begin
323     if Result<>nil then
324       Result[p]:=i;
325     inc(p);
326   end;
327 
328   procedure CreateList;
329   begin
330     //Add(kCGLPFAWindow); deprecated since 10.9
331     Add(kCGLPFAAccelerated);
332     if DoubleBuffered then
333       Add(kCGLPFADoubleBuffer);
334     //if (MajorVersion>=3) and (MinorVersion>=2) then
335     //   Add(kCGLOGLPVersion);
336     Add(kCGLPFANoRecovery);
337     Add(kCGLPFAMaximumPolicy);
338     Add(kCGLPFASingleRenderer);
339     if AlphaBits>0 then
340     begin
341       Add(kCGLPFAAlphaSize);  Add(AlphaBits);
342     end;
343     if DepthBits>0 then
344     begin
345       Add(kCGLPFADepthSize);  Add(DepthBits);
346     end;
347     if StencilBits>0 then
348     begin
349       Add(kCGLPFAStencilSize);  Add(StencilBits);
350     end;
351     if AUXBuffers>0 then
352     begin
353       //Add(kCGLPFAAuxBuffers);  Add(AUXBuffers); ToDo
354     end;
355     if MultiSampling > 1 then
356     begin
357       Add(kCGLPFASampleBuffers); Add(1);
358       Add(kCGLPFASamples); Add(MultiSampling);
359     end;
360 
361     Add(0); // end of list
362   end;
363 
364 begin
365   Result:=nil;
366   p:=0;
367   CreateList;
368   GetMem(Result,SizeOf(integer)*p);
369   p:=0;
370   CreateList;
371 end;
372 
373 function IsCGLPixelFormatAvailable(Attribs: PInteger): boolean;
374 var
375   //display: CGDirectDisplayID;
376   aPixFormatObj: CGLPixelFormatObj;
377   aPixObjCountAttrList: GLint;
378 begin
379   //display := CGMainDisplayID();
380   if CGLChoosePixelFormat(Attribs, @aPixFormatObj, @aPixObjCountAttrList)<>kCGLNoError
381   then
382     exit(false);
383   if aPixFormatObj=nil then
384     exit(false);
385   Result:=true;
386   // ToDo: free aPixFormatObj
387 end;              *)
388 
389 { TCocoaOpenGLView }
390 
acceptsFirstRespondernull391 function TCocoaOpenGLView.acceptsFirstResponder: LCLObjCBoolean;
392 begin
393   Result := True;
394 end;
395 
becomeFirstRespondernull396 function TCocoaOpenGLView.becomeFirstResponder: LCLObjCBoolean;
397 begin
398   Result:=inherited becomeFirstResponder;
399   callback.BecomeFirstResponder;
400 end;
401 
resignFirstRespondernull402 function TCocoaOpenGLView.resignFirstResponder: LCLObjCBoolean;
403 begin
404   Result:=inherited resignFirstResponder;
405   callback.ResignFirstResponder;
406 end;
407 
408 procedure TCocoaOpenGLView.dealloc;
409 begin
410   inherited dealloc;
411 end;
412 
lclGetCallbacknull413 function TCocoaOpenGLView.lclGetCallback: ICommonCallback;
414 begin
415   Result := callback;
416 end;
417 
418 procedure TCocoaOpenGLView.lclClearCallback;
419 begin
420   callback := nil;
421 end;
422 
lclIsEnablednull423 function TCocoaOpenGLView.lclIsEnabled: Boolean;
424 begin
425   Result := Owner.Enabled;
426 end;
427 
428 procedure TCocoaOpenGLView.mouseDown(event: NSEvent);
429 begin
430   if not Assigned(callback) or not callback.MouseUpDownEvent(event) then
431   begin
432     // do not pass mouseDown below or it will pass it to the parent control
433     // causing double events
434     //inherited mouseDown(event);
435   end;
436 end;
437 
438 procedure TCocoaOpenGLView.mouseUp(event: NSEvent);
439 begin
440   if not Assigned(callback) or not callback.MouseUpDownEvent(event) then
441     inherited mouseUp(event);
442 end;
443 
444 procedure TCocoaOpenGLView.rightMouseDown(event: NSEvent);
445 begin
446   if not Assigned(callback) or not callback.MouseUpDownEvent(event) then
447     inherited rightMouseDown(event);
448 end;
449 
450 procedure TCocoaOpenGLView.rightMouseUp(event: NSEvent);
451 begin
452   if not Assigned(callback) or not callback.MouseUpDownEvent(event) then
453     inherited rightMouseUp(event);
454 end;
455 
456 procedure TCocoaOpenGLView.rightMouseDragged(event: NSEvent);
457 begin
458   if not Assigned(callback) or not callback.MouseMove(event) then
459     inherited rightMouseDragged(event);
460 end;
461 
462 procedure TCocoaOpenGLView.otherMouseDown(event: NSEvent);
463 begin
464   if not Assigned(callback) or not callback.MouseUpDownEvent(event) then
465     inherited otherMouseDown(event);
466 end;
467 
468 procedure TCocoaOpenGLView.otherMouseUp(event: NSEvent);
469 begin
470   if not Assigned(callback) or not callback.MouseUpDownEvent(event) then
471     inherited otherMouseUp(event);
472 end;
473 
474 procedure TCocoaOpenGLView.otherMouseDragged(event: NSEvent);
475 begin
476   if not Assigned(callback) or not callback.MouseMove(event) then
477     inherited otherMouseDragged(event);
478 end;
479 
480 procedure TCocoaOpenGLView.mouseDragged(event: NSEvent);
481 begin
482   if Assigned(callback)
483     then callback.MouseMove(event)
484     else inherited mouseDragged(event);
485 end;
486 
487 procedure TCocoaOpenGLView.mouseEntered(event: NSEvent);
488 begin
489   inherited mouseEntered(event);
490 end;
491 
492 procedure TCocoaOpenGLView.mouseExited(event: NSEvent);
493 begin
494   inherited mouseExited(event);
495 end;
496 
497 procedure TCocoaOpenGLView.mouseMoved(event: NSEvent);
498 begin
499   if not Assigned(callback) or not callback.MouseMove(event) then
500     inherited mouseMoved(event);
501 end;
502 
503 procedure TCocoaOpenGLView.scrollWheel(event: NSEvent);
504 begin
505   if Assigned(callback)
506     then callback.scrollWheel(event)
507     else inherited scrollWheel(event);
508 end;
509 
510 procedure TCocoaOpenGLView.resetCursorRects;
511 begin
512   if not Assigned(callback) or not callback.resetCursorRects then
513     inherited resetCursorRects;
514 end;
515 
516 procedure TCocoaOpenGLView.drawRect(dirtyRect: NSRect);
517 var
518   ctx : NSGraphicsContext;
519   PS  : TPaintStruct;
520   r   : NSRect;
521 begin
522   ctx := NSGraphicsContext.currentContext;
523   inherited drawRect(dirtyRect);
524   if CheckMainThread and Assigned(callback) then
525   begin
526     if ctx = nil then
527     begin
528       // In macOS 10.14 (mojave) current context is nil
529       // we still can paint anything releated to OpenGL!
530       // todo: consider creating a dummy context (for a bitmap)
531       FillChar(PS, SizeOf(TPaintStruct), 0);
532       r := frame;
533       r.origin.x:=0;
534       r.origin.y:=0;
535       PS.hdc := HDC(0);
536       PS.rcPaint := NSRectToRect(r);
537       LCLSendPaintMsg(Owner, HDC(0), @PS);
538     end
539     else
540       callback.Draw(ctx, bounds, dirtyRect);
541   end;
542 end;
543 
544 end.
545 
546