`make-gl-bitmap' for cocoa and maybe gtk

original commit: 0a47a81aba1c9e2f88984357b0d665700a360ee1

collects/mred/mred-sig.rkt

@@ -123,6 +123,7 @@ make-eventspace
 make-gui-empty-namespace
 make-gui-namespace
 make-screen-bitmap
+make-gl-bitmap
 map-command-as-meta-key
 menu%
 menu-bar%

collects/mred/mred.rkt

@@ -191,7 +191,8 @@
              the-brush-list
              the-style-list
              the-editor-wordbreak-map
-             make-screen-bitmap)
+             make-screen-bitmap
+             make-gl-bitmap)
    
   (define the-clipboard (wx:get-the-clipboard))
   (define the-x-selection-clipboard (wx:get-the-x-selection))

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

@@ -206,12 +206,11 @@
             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
+                       NSOpenGLPFASampleBuffers 1
                        NSOpenGLPFASamples ms)))
            (list 0)))))
         

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

@@ -85,4 +85,5 @@
    get-highlight-background-color
    get-highlight-text-color
    make-screen-bitmap
+   make-gl-bitmap
    check-for-break))

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

@@ -12,6 +12,7 @@
          "filedialog.rkt"
          "dc.rkt"
          "menu-bar.rkt"
+         "agl.rkt"
          "../../lock.rkt"
          "../common/handlers.rkt")
 
@@ -52,6 +53,7 @@
  get-highlight-background-color
  get-highlight-text-color
  make-screen-bitmap
+ make-gl-bitmap
  check-for-break)
 
 (import-class NSScreen NSCursor)
@@ -113,6 +115,11 @@
                                 [exact-positive-integer? h])
   (make-object quartz-bitmap% w h))
 
+(define/top (make-gl-bitmap [exact-positive-integer? w]
+                            [exact-positive-integer? h]
+                            [gl-config% c])
+  (create-gl-bitmap w h c))
+
 ;; ------------------------------------------------------------
 ;; Text & highlight color
 

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

@@ -37,6 +37,14 @@
                                  w
                                  h))
 
+    ;; `get-gdk-pixmap' and `install-gl-context' are
+    ;; localized in "gl-context.rkt"
+    (define/public (get-gdk-pixmap) pixmap)
+    (define/public (install-gl-context new-gl) (set! gl new-gl))
+
+    (define gl #f)
+    (define/override (get-bitmap-gl-context) gl)
+
     (define/override (ok?) #t)
     (define/override (is-color?) #t)
     (define/override (has-alpha-channel?) #f)

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

@@ -2,13 +2,18 @@
 (require racket/class
          ffi/unsafe
          ffi/unsafe/define
+         ffi/unsafe/alloc
          (prefix-in draw: racket/draw/gl-context)
          racket/draw/gl-config
          "types.rkt"
          "utils.rkt")
 
 (provide prepare-widget-gl-context
-	 create-widget-gl-context)
+	 create-widget-gl-context
+
+         create-and-install-gl-context
+         get-gdk-pixmap
+         install-gl-context)
 
 (define gdkglext-lib
   (ffi-lib "libgdkglext-x11-1.0" '("0")))
@@ -23,6 +28,8 @@
 (define _GdkGLContext (_cpointer/null 'GdkGLContext))
 (define _GdkGLDrawable (_cpointer 'GdkGLDrawable))
 (define _GdkGLConfig (_cpointer 'GdkGLConfig))
+(define _GdkGLPixmap _GdkGLDrawable)
+(define _GdkPixmap _pointer)
 
 (define-gdkglext gdk_gl_init (_fun (_ptr i _int)
                                    (_ptr i _pointer)
@@ -45,12 +52,26 @@
 (define-gtkglext gtk_widget_get_gl_context (_fun _GtkWidget -> _GdkGLContext))
 (define-gtkglext gtk_widget_get_gl_window (_fun _GtkWidget -> _GdkGLDrawable))
 
+(define-gdkglext gdk_gl_context_destroy (_fun _GdkGLContext -> _void)
+  #:wrap (deallocator))
+
+(define-gdkglext gdk_gl_context_new (_fun _GdkGLDrawable _GdkGLContext _gboolean _int
+                                          -> _GdkGLContext)
+  #:wrap (allocator gdk_gl_context_destroy))
+
 (define-gdkglext gdk_gl_drawable_gl_begin (_fun _GdkGLDrawable
                                                 _GdkGLContext
                                                 -> _gboolean))
 (define-gdkglext gdk_gl_drawable_gl_end (_fun _GdkGLDrawable -> _void))
 (define-gdkglext gdk_gl_drawable_swap_buffers (_fun _GdkGLDrawable -> _void))
 
+(define-gdkglext gdk_gl_pixmap_destroy (_fun _GdkGLPixmap -> _void)
+  #:wrap (deallocator))
+(define-gdkglext gdk_gl_pixmap_new (_fun _GdkGLConfig _GdkPixmap _pointer -> _GdkGLPixmap)
+  #:wrap (allocator gdk_gl_pixmap_destroy))
+
+(define GDK_GL_RGBA_TYPE 0)
+
 (define GDK_GL_USE_GL                     1)
 (define GDK_GL_BUFFER_SIZE                2)
 (define GDK_GL_LEVEL                      3)
@@ -74,10 +95,12 @@
 
 ;; ----------------------------------------
 
-(define (config->GdkGLConfig d conf)
+(define (config->GdkGLConfig d conf can-double?)
   (gdk_gl_config_new (append
 		      (list GDK_GL_RGBA)
-		      (if (send conf get-double-buffered) (list GDK_GL_DOUBLEBUFFER) null)
+                      (if can-double?
+                          (if (send conf get-double-buffered) (list GDK_GL_DOUBLEBUFFER) null)
+                          null)
 		      (if (send conf get-stereo) (list GDK_GL_STEREO) null)
 		      (list
 		       GDK_GL_DEPTH_SIZE (send conf get-depth-size)
@@ -122,7 +145,8 @@
   (init!)
   (let ([config (config->GdkGLConfig #f ; (gtk_widget_get_screen gtk)
                                      (or config
-                                         (new gl-config%)))])
+                                         (new gl-config%))
+                                     #t)])
     (when config
 	  (gtk_widget_set_gl_capability gtk
 					config
@@ -138,3 +162,21 @@
 	      [gl gl]
 	      [drawable (gtk_widget_get_gl_window gtk)]))))
 
+
+(define-local-member-name
+  get-gdk-pixmap
+  install-gl-context)
+
+(define (create-and-install-gl-context bm config)
+  (init!)
+  (let ([config (config->GdkGLConfig #f config #f)])
+    (when config
+      (let ([gdkpx (send bm get-gdk-pixmap)])
+        (let ([glpx (gdk_gl_pixmap_new config gdkpx #f)])
+          (and glpx
+               (let ([gl (gdk_gl_context_new glpx #f #t GDK_GL_RGBA_TYPE)])
+                 (and gl
+                      (new gl-context% 
+                           [gl gl]
+                           [drawable glpx])))))))))
+

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

@@ -85,4 +85,5 @@
    get-highlight-background-color
    get-highlight-text-color
    make-screen-bitmap
+   make-gl-bitmap
    check-for-break))

collects/mred/private/wx/gtk/procs.rkt

@@ -11,6 +11,7 @@
          "widget.rkt"
          "window.rkt"
          "dc.rkt"
+         "gl-context.rkt"
          "../common/handlers.rkt")
 
 (provide
@@ -50,6 +51,7 @@
  get-highlight-background-color
  get-highlight-text-color
  make-screen-bitmap
+ make-gl-bitmap
  check-for-break)
 
 (define-unimplemented special-control-key)
@@ -118,4 +120,11 @@
       (make-object x11-bitmap% w h #f)
       (make-object bitmap% w h #f #t)))
 
+(define/top (make-gl-bitmap [exact-positive-integer? w]
+                            [exact-positive-integer? h]
+                            [gl-config% c])
+  (let ([bm (make-object x11-bitmap% w h #f)])
+    (create-and-install-gl-context bm c)
+    bm))
+
 (define (check-for-break) #f)

collects/mred/private/wx/platform.rkt

@@ -70,5 +70,6 @@
                 get-highlight-background-color
                 get-highlight-text-color
                 make-screen-bitmap
+                make-gl-bitmap
                 check-for-break)
   ((dynamic-require platform-lib 'platform-values)))

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

@@ -86,4 +86,5 @@
    get-highlight-background-color
    get-highlight-text-color
    make-screen-bitmap
+   make-gl-bitmap
    check-for-break))

collects/mred/private/wx/win32/procs.rkt

@@ -48,6 +48,7 @@
  get-highlight-background-color
  get-highlight-text-color
  make-screen-bitmap
+ make-gl-bitmap
  check-for-break)
 
 (define-unimplemented special-control-key)
@@ -102,4 +103,9 @@
                                 [exact-positive-integer? h])
   (make-object win32-bitmap% w h #f))
 
+(define/top (make-gl-bitmap [exact-positive-integer? w]
+                            [exact-positive-integer? h]
+                            [gl-config% c])
+  (make-object win32-bitmap% w h #f))
+
 (define (check-for-break) #f)

collects/scribblings/gui/canvas-class.scrbl

@@ -45,10 +45,11 @@ 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] --- enables OpenGL drawing to the canvas, and usually
+ @item{@scheme['gl] --- creates a canvas for OpenGL drawing instead of
-       combined with @racket['no-autoclear]; call the @method[dc<%>
+       normal @racket[dc<%>] drawing; call the @method[dc<%>
-       get-gl-context] method of the canvas's drawing context as
+       get-gl-context] method on the result of @method[canvas<%>
-       produced by @method[canvas<%> get-dc]}
+       get-dc]; this style is usually combined with
+       @racket['no-autoclear]}
 
  @item{@scheme['no-autoclear] --- prevents automatic erasing of the
        canvas before calls to @method[canvas% on-paint]} 

collects/scribblings/gui/miscwin-funcs.scrbl

@@ -276,6 +276,20 @@ Strips shortcut ampersands from @racket[label], removes parenthesized
 }
 
 
+@defproc[(make-gl-bitmap [width exact-positive-integer?]
+                         [height exact-positive-integer?]
+                         [config (is-a?/c gl-config%)])
+         (is-a/c? bitmap%)]{
+
+Creates a bitmap that supports both normal @racket[dc<%>] drawing an
+OpenGL drawing through a context returned by @xmethod[dc<%> get-gl-context].
+
+For @racket[dc<%>] drawing, an OpenGL-supporting bitmap draws like a
+bitmap frmo @racket[make-screen-bitmap] on some platforms, while it
+draws like a bitmap instantiated directly from @racket[bitmap%] on
+other platforms.}
+
+
 @defproc[(make-gui-empty-namespace) namespace?]{
 
 Like @racket[make-base-empty-namespace], but with

doc/release-notes/racket/Draw_and_GUI_5_5.txt

@@ -1,4 +1,4 @@
-Changes to the drawing toolbox:
+Changes:
 
  * The drawing portion of the old GUI toolbox is now available as a
    separate layer: `racket/draw'. This layer can be used from plain
@@ -15,7 +15,7 @@ Changes to the drawing toolbox:
 
    Drawing to a canvas always draws into a bitmap that is kept
    offscreen and periodically flushed onto the screen. The new
-   `suspend-flush' and `resume-fluah' methods of `canvas%' provide
+   `suspend-flush' and `resume-flush' methods of `canvas%' provide
    some control over the timing of the flushes, which in many cases
    avoids the need for (additional) double buffering of canvas
    content.
@@ -85,8 +85,9 @@ Changes to the drawing toolbox:
    `get-highlight-text-color', if any.
 
  * OpenGL drawing in a canvas requires supplying 'gl as a style when
-   creating the `canvas%' instance.
+   creating the `canvas%' instance. OpenGL and normal dc<%> drawing no
+   longer mix reliably in a canvas.
 
-Changes to the GUI toolbox:
+   OpenG drawing to a bitmap requires a bitmap created with
+   `make-gl-bitmap'.
 
- [Nothing to report, yet.]