cocoa: opengl canvases

collects/mred/private/wx/cocoa/canvas.rkt

@@ -3,6 +3,7 @@
          ffi/unsafe
          racket/class
          racket/draw
+         racket/draw/gl-context
          racket/draw/color
          "pool.rkt"
          "utils.rkt"
@@ -28,7 +29,8 @@
 ;; ----------------------------------------
 
 (import-class NSView NSGraphicsContext NSScroller NSComboBox NSWindow 
-              NSImageView NSTextFieldCell)
+              NSImageView NSTextFieldCell 
+              NSOpenGLView NSOpenGLPixelFormat)
 
 (import-protocol NSComboBoxDelegate)
 
@@ -55,7 +57,7 @@
                                                  (make-NSSize 32000 32000))))
             (tellv ctx restoreGraphicsState)))))))
 
-(define-objc-class MyView NSView 
+(define-objc-mixin (MyViewMixin Superclass)
   #:mixins (FocusResponder KeyMouseTextResponder CursorDisplayer) 
   [wxb]
   (-a _void (drawRect: [_NSRect r])
@@ -80,6 +82,14 @@
         (let ([wx (->wx wxb)])
           (when wx (send wx do-scroll 'vertical scroller))))))
 
+(define-objc-class MyView NSView 
+  #:mixins (MyViewMixin)
+  [wxb])
+
+(define-objc-class MyGLView NSOpenGLView
+  #:mixins (MyViewMixin)
+  [wxb])
+
 (define-objc-class FrameView NSView 
   []
   (-a _void (drawRect: [_NSRect r])
@@ -173,6 +183,39 @@
           (when wx
             (queue-window-event wx (lambda () (send wx fix-dc))))))))
 
+(define NSOpenGLPFADoubleBuffer 5)
+(define NSOpenGLPFAStereo 6)
+(define NSOpenGLPFAColorSize 8)
+(define NSOpenGLPFAAlphaSize 11)
+(define NSOpenGLPFADepthSize 12)
+(define NSOpenGLPFAStencilSize 13)
+(define NSOpenGLPFAAccumSize 14)
+(define NSOpenGLPFAOffScreen 53)
+(define NSOpenGLPFASampleBuffers 55)
+(define NSOpenGLPFASamples 56)
+(define NSOpenGLPFAMultisample 59)
+
+(define (gl-config->pixel-format conf)
+  (let ([conf (or conf (new gl-config%))])
+    (tell (tell NSOpenGLPixelFormat alloc)
+          initWithAttributes: #:type (_list i _int)
+          (append
+           (if (send conf get-double-buffered) (list NSOpenGLPFADoubleBuffer) null)
+           (if (send conf get-stereo) (list NSOpenGLPFAStereo) null)
+           (list
+            NSOpenGLPFADepthSize (send conf get-depth-size)
+            NSOpenGLPFAStencilSize (send conf get-stencil-size)
+            NSOpenGLPFAAccumSize (send conf get-accum-size))
+           #;
+           (let ([ms (send conf get-multisample-size)])
+             (if (zero? ms)
+                 null
+                 (list NSOpenGLPFAMultisample
+                       NSOpenGLPFASampleBuffers
+                       NSOpenGLPFASamples ms)))
+           (list 0)))))
+        
+  
 (define-struct scroller (cocoa [range #:mutable] [page #:mutable]))
 (define scroll-width (tell #:type _CGFloat NSScroller scrollerWidth))
 
@@ -259,6 +302,9 @@
 
      (define/override (get-cocoa-content) content-cocoa)
 
+     (define is-gl? (and (not is-combo?) (memq 'gl style)))
+     (define/public (can-gl?) is-gl?)
+
      (super-new 
       [parent parent]
       [cocoa
@@ -283,8 +329,12 @@
                              (make-NSSize (max 0 (- w (* 2 x-margin)))
                                           (max 0 (- h (* 2 y-margin)))))])
          (as-objc-allocation
-          (tell (tell (if is-combo? MyComboBox MyView) alloc) 
-                initWithFrame: #:type _NSRect r))))
+          (if (or is-combo? (not (memq 'gl style)))
+              (tell (tell (if is-combo? MyComboBox MyView) alloc) 
+                    initWithFrame: #:type _NSRect r)
+              (tell (tell MyGLView alloc) 
+                    initWithFrame: #:type _NSRect r
+                    pixelFormat: (gl-config->pixel-format gl-config))))))
      (tell #:type _void cocoa addSubview: content-cocoa)
      (set-ivar! content-cocoa wxb (->wxb this))
 

collects/mred/private/wx/cocoa/dc.rkt

@@ -5,6 +5,7 @@
          racket/draw/cairo
          racket/draw/bitmap
          racket/draw/local
+         racket/draw/gl-context
          "types.rkt"
          "utils.rkt"
          "window.rkt"
@@ -17,6 +18,8 @@
          quartz-bitmap%
          do-backing-flush)
 
+(import-class NSOpenGLContext)
+
 (define quartz-bitmap%
   (class bitmap%
     (init w h)
@@ -46,6 +49,23 @@
 
     (super-new)
 
+    (define gl #f)
+    (define/override (get-gl-context)
+      (and (send canvas can-gl?)
+           (let ([gl-ctx (tell (send canvas get-cocoa-content) openGLContext)])
+             (or gl
+                 (let ([g (new (class gl-context%
+                                 (define/override (do-call-as-current t)
+                                   (dynamic-wind
+                                       (lambda () (tellv gl-ctx makeCurrentContext))
+                                       t
+                                       (lambda () (tellv NSOpenGLContext clearCurrentContext))))
+                                 (define/override (do-swap-buffers)
+                                   (tellv gl-ctx flushBuffer))
+                                 (super-new)))])
+                   (set! gl g)
+                   g)))))
+
     ;; Use a quartz bitmap so that text looks good:
     (define/override (make-backing-bitmap w h) (make-object quartz-bitmap% w h))
     (define/override (can-combine-text? sz) #t)

collects/mred/private/wx/cocoa/gl-context.rkt

@@ -1,11 +0,0 @@
-#lang scheme/base
-(require scheme/class
-          "../../syntax.rkt")
-
-(provide gl-context%)
-
-(defclass gl-context% object%
-  (def/public-unimplemented call-as-current)
-  (def/public-unimplemented swap-buffers)
-  (def/public-unimplemented ok?)
-  (super-new))

collects/mred/private/wx/cocoa/platform.rkt

@@ -9,7 +9,6 @@
          "dialog.rkt"
          "frame.rkt"
          "gauge.rkt"
-         "gl-context.rkt"
          "group-panel.rkt"
          "item.rkt"
          "list-box.rkt"

collects/scribblings/gui/canvas-class.scrbl

@@ -45,11 +45,14 @@ The @scheme[style] argument indicates one or more of the following styles:
  @item{@scheme['resize-corner] --- leaves room for a resize control at the canvas's
                                   bottom right when only one scrollbar is visible}
 
- @item{@scheme['gl] --- @italic{obsolete} (every canvas is an OpenGL context where supported)}
+ @item{@scheme['gl] --- enables OpenGL drawing to the canvas, and usually
+       combined with @racket['no-autoclear]; call the @method[dc<%>
+       get-gl-context] method of the canvas's drawing context as
+       produced by @method[canvas<%> get-dc]}
 
  @item{@scheme['no-autoclear] --- prevents automatic erasing of the
- canvas before calls to
-@method[canvas% on-paint]} 
+       canvas before calls to @method[canvas% on-paint]} 
+
  @item{@scheme['transparent] --- the canvas is automatically ``erased''
  before an update using it's parent window's background; the result is
  undefined if this flag is combined with @scheme['no-autoclear]}

doc/release-notes/racket/Draw_and_GUI_5_5.txt

@@ -84,6 +84,9 @@ Changes to the drawing toolbox:
    the foreground in the color specified by
    `get-highlight-text-color', if any.
 
+ * OpenGL drawing in a canvas requires supplying 'gl as a style when
+   creating the `canvas%' instance.
+
 Changes to the GUI toolbox:
 
  [Nothing to report, yet.]