racket/gui cocoa: revive make-gl-bitmap for Mac OS X 10.7 and up

Port from AppleGL to CoreGL, and implement offscreen drawing through a framebuffer instead of CGLSetOffScreen() for 10.7 and later.
2014-07-31 14:47:30 +01:00 · 2014-07-31 14:47:30 +01:00 · a57734d7ae
commit a57734d7ae
parent efd7593097
6 changed files with 415 additions and 216 deletions
--- a/pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap.rkt
+++ b/pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap.rkt
@ -27,7 +27,8 @@
                      build-cairo-surface
                      quartz-bitmap%
                      win32-no-hwnd-bitmap%
-                      install-bitmap-dc-class!))
+                      install-bitmap-dc-class!
+                      surface-flush))

 (define -bitmap-dc% #f)
 (define (install-bitmap-dc-class! v) (set! -bitmap-dc% v))
@ -39,7 +40,8 @@

 (define-local-member-name
  get-alphas-as-mask
-  set-alphas-as-mask)
+  set-alphas-as-mask
+  surface-flush)

 (define (bitmap-file-kind-symbol? s)
  (memq s '(unknown unknown/mask unknown/alpha
@ -171,6 +173,9 @@
    (init-rest args)
    (super-new)

+    (define/public (surface-flush)
+      (cairo_surface_flush s))
+
    (define-values (alt? width height b&w? alpha-channel? s loaded-mask backing-scale)
      (case-args
       args
@ -594,7 +599,7 @@
               ;; Write a 1-bit png
               (let* ([b (ceiling (/ width 8))]
                      [rows (build-vector height (lambda (i) (make-bytes b)))]
-                      [data (begin (cairo_surface_flush s)
+                      [data (begin (surface-flush)
                                   (cairo_image_surface_get_data s))]
                      [row-width (cairo_image_surface_get_stride s)])
                 (for ([j (in-range height)])
@ -736,7 +741,7 @@
      ;; Get pixels:
      (when (not get-alpha?)
        (let-values ([(A R G B) (argb-indices)])
-          (cairo_surface_flush s)
+          (surface-flush)
          (let ([data (cairo_image_surface_get_data s)]
                [row-width (cairo_image_surface_get_stride s)]
                [um (and (or (and alpha-channel? (not pre-mult?)) b&w?)
@ -815,7 +820,7 @@
                     [(width) (if unscaled? (*i width backing-scale) width)]
                     [(height) (if unscaled? (*i height backing-scale) height)])
          (when (not set-alpha?)
-            (cairo_surface_flush s)
+            (surface-flush)
            (let ([data (cairo_image_surface_get_data s)]
                  [row-width (cairo_image_surface_get_stride s)]
                  [m (and (not pre-mult?) (get-mult-table))])
@ -881,7 +886,7 @@
    (define/public (get-alphas-as-mask x y w h bstr width height)
      (let ([data (cairo_image_surface_get_data (if (or b&w? alpha-channel?)
                                                    (begin
-                                                      (cairo_surface_flush s)
+                                                      (surface-flush)
                                                      s)
                                                    (begin
                                                      (prep-alpha width height)
@ -903,7 +908,7 @@
          (unless alpha-s
            (set! alpha-s (cairo_image_surface_create CAIRO_FORMAT_ARGB32
                                                      width height)))
-          (cairo_surface_flush s)
+          (surface-flush)
          (cairo_surface_flush alpha-s)
          (let ([data (cairo_image_surface_get_data s)]
                [alpha-data (cairo_image_surface_get_data alpha-s)]
@ -939,7 +944,7 @@
              [row-width (cairo_image_surface_get_stride s)]
              [A (a-index)]
              [B (b-index)])
-          (cairo_surface_flush s)
+          (surface-flush)
          (for ([j (in-range y (min (+ y h) height))])
            (let ([row (* j row-width)]
                  [src-row (* (- j y) src-w)])
--- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/agl.rkt
+++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/agl.rkt
@ -1,155 +0,0 @@
-#lang racket/base
-(require racket/class
-         ffi/unsafe
-         ffi/unsafe/define
-         ffi/unsafe/alloc
-         "../../lock.rkt"
-         racket/draw/unsafe/cairo
-         racket/draw/private/local
-         racket/draw/private/gl-context
-         racket/draw/private/gl-config
-         racket/draw/private/bitmap)
-
-(provide (protect-out create-gl-bitmap))
-
-(define agl-lib 
-  (ffi-lib "/System/Library/Frameworks/AGL.framework/AGL"))
-
-(define-ffi-definer define-agl agl-lib)
-
-(define _GLsizei _int)
-(define _GLint _int)
-(define _GLboolean _bool)
-(define _AGLPixelFormat (_cpointer/null 'AGLPixelFormat))
-(define _AGLContext (_cpointer/null 'AGLContext))
-
-(define-agl aglChoosePixelFormat (_fun _pointer _GLint (_list i _GLint) -> _AGLPixelFormat))
-(define-agl aglDestroyContext (_fun _AGLContext -> _GLboolean)
-  #:wrap (deallocator))
-(define-agl aglCreateContext (_fun _AGLPixelFormat _AGLContext -> _AGLContext)
-  #:wrap (allocator aglDestroyContext))
-
-(define-agl aglSetOffScreen (_fun _AGLContext _GLsizei _GLsizei _GLsizei _pointer
-                                  -> _GLboolean))
-
-(define-agl aglSetCurrentContext (_fun _AGLContext -> _GLboolean))
-
-(define AGL_NONE                   0)
-(define AGL_BUFFER_SIZE            2)
-(define AGL_LEVEL                  3)
-(define AGL_RGBA                   4)
-(define AGL_DOUBLEBUFFER           5)
-(define AGL_STEREO                 6)
-(define AGL_AUX_BUFFERS            7)
-(define AGL_RED_SIZE               8)
-(define AGL_GREEN_SIZE             9)
-(define AGL_BLUE_SIZE             10)
-(define AGL_ALPHA_SIZE            11)
-(define AGL_DEPTH_SIZE            12)
-(define AGL_STENCIL_SIZE          13)
-(define AGL_ACCUM_RED_SIZE        14)
-(define AGL_ACCUM_GREEN_SIZE      15)
-(define AGL_ACCUM_BLUE_SIZE       16)
-(define AGL_ACCUM_ALPHA_SIZE      17)
-(define AGL_PIXEL_SIZE            50)
-(define AGL_OFFSCREEN             53)
-(define AGL_SAMPLE_BUFFERS_ARB    55)
-(define AGL_SAMPLES_ARB           56)
-(define AGL_AUX_DEPTH_STENCIL     57)
-(define AGL_COLOR_FLOAT           58)
-(define AGL_MULTISAMPLE           59)
-(define AGL_SUPERSAMPLE           60)
-(define AGL_SAMPLE_ALPHA          61)
-
-(define dummy-agl #f)
-(define current-agl #f)
-
-(define agl-context%
-  (let ([orig-gl-context% gl-context%])
-    (define gl-context%
-      (class orig-gl-context%
-        (init-field agl)
-
-        (define/override (get-handle)
-          agl)
-        
-        (define/override (do-call-as-current t)
-          (dynamic-wind
-              (lambda () 
-                (atomically
-                 (aglSetCurrentContext agl)
-                 (set! current-agl agl)))
-              t
-              (lambda () 
-                (atomically
-                 (aglSetCurrentContext dummy-agl)
-                 (set! current-agl #f)))))
-
-        (define/override (do-swap-buffers)
-          (void))
-
-        (super-new)))
-    gl-context%))
-    
-
-(define agl-bitmap%
-  (let ([orig-bitmap% bitmap%])
-    (define bitmap%
-      (class orig-bitmap%
-        (init agl)
-        (super-new)
-
-        (define ctx (make-object agl-context% agl))
-
-        (define/override (get-bitmap-gl-context)
-          ctx)
-
-        (define/override (release-bitmap-storage)
-          (set! ctx #f)
-          (super release-bitmap-storage))))
-    bitmap%))
-
-(define (create-gl-bitmap w h conf)
-  (let* ([share-context (send conf get-share-context)]
-         [context-handle (if share-context (send share-context get-handle) #f)]
-         [fmt (aglChoosePixelFormat
-              #f
-              0
-              (append
-               (list AGL_RGBA
-                     AGL_PIXEL_SIZE 32
-                     AGL_OFFSCREEN)
-               (if (send conf get-stereo) (list AGL_STEREO) null)
-               (list
-                AGL_DEPTH_SIZE (send conf get-depth-size)
-                AGL_STENCIL_SIZE (send conf get-stencil-size))
-               (let ([as (send conf get-accum-size)])
-                 (if (zero? as)
-                     null
-                     (list AGL_ACCUM_RED_SIZE as
-                           AGL_ACCUM_GREEN_SIZE as
-                           AGL_ACCUM_BLUE_SIZE as
-                           AGL_ACCUM_ALPHA_SIZE as)))
-               (let ([ms (send conf get-multisample-size)])
-                 (if (zero? ms)
-                     null
-                     (list AGL_SAMPLE_BUFFERS_ARB 1
-                           AGL_SAMPLES_ARB ms)))
-               (list AGL_NONE)))])
-    (and fmt
-         (let ([agl (aglCreateContext fmt context-handle)]
-               [d-agl (or dummy-agl
-                          (let ([d (aglCreateContext fmt context-handle)])
-                            (when d
-                              (set! dummy-agl d)
-                              d)))])
-           (and agl
-                d-agl
-                (let ([bm (make-object agl-bitmap% agl w h #f #t)])
-                  (and (send bm ok?)
-                       (let ([s (send bm get-cairo-surface)])
-                         (and (aglSetOffScreen agl w h
-                                               (cairo_image_surface_get_stride s)
-                                               (cairo_image_surface_get_data s))
-                              bm)))))))))
-
--- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/cgl.rkt
+++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/cgl.rkt
@ -0,0 +1,289 @@
+#lang racket/base
+(require racket/class
+         ffi/unsafe
+         ffi/unsafe/define
+         ffi/unsafe/alloc
+         "../../lock.rkt"
+         "utils.rkt"
+         racket/draw/unsafe/cairo
+         racket/draw/private/local
+         racket/draw/private/gl-context
+         racket/draw/private/gl-config
+         racket/draw/private/bitmap)
+
+(provide (protect-out create-gl-bitmap))
+
+(define cgl-lib 
+  (ffi-lib "/System/Library/Frameworks/OpenGL.framework/OpenGL"))
+
+(define-ffi-definer define-cgl cgl-lib)
+
+(define _GLsizei _int)
+(define _GLenum _int)
+(define _GLboolean _bool)
+(define _GLint _int)
+(define _GLuint _uint)
+(define _CGLPixelFormatAttribute _int)
+(define _CGLError _int)
+(define _CGLPixelFormatObj (_cpointer/null 'CGLPixelFormatObj))
+(define _CGLContextObj (_cpointer/null 'CGLContextObj))
+
+(define (check-ok who r)
+  (unless (zero? r)
+    (error who "failed\n   error code: ~e" r)))
+
+(define-cgl CGLChoosePixelFormat (_fun (_list i _CGLPixelFormatAttribute)
+                                       (fmt : (_ptr o _CGLPixelFormatObj))
+                                       (n : (_ptr o _GLint))
+                                       -> (r : _CGLError)
+                                       -> (and (zero? r) fmt)))
+(define-cgl CGLDestroyPixelFormat (_fun _CGLPixelFormatObj
+                                        -> (r : _CGLError)
+                                        -> (check-ok 'CGLDestroyPixelFormat r)))
+
+(define-cgl CGLDestroyContext (_fun _CGLContextObj
+                                    -> (r : _CGLError)
+                                    -> (check-ok 'CGLDestroyContext r))
+  #:wrap (deallocator))
+(define-cgl CGLCreateContext (_fun _CGLPixelFormatObj
+                                   _CGLContextObj
+                                   (ctx : (_ptr o _CGLContextObj))
+                                   -> (r : _CGLError)
+                                   -> (and (zero? r) ctx))
+  #:wrap (allocator CGLDestroyContext))
+
+(define-cgl CGLSetOffScreen (_fun _CGLContextObj _GLsizei _GLsizei _GLsizei _pointer
+                                  -> (r : _CGLError)
+                                  -> (check-ok 'CGLSetOffScreen r)))
+
+(define-cgl CGLSetCurrentContext (_fun _CGLContextObj 
+                                       -> (r : _CGLError)
+                                       -> (check-ok 'CGLSetCurrentContext r)))
+
+(define-cgl glGenFramebuffersEXT (_fun _GLint (fb : (_ptr o _GLuint))
+                                       -> _void
+                                       -> fb))
+(define-cgl glBindFramebufferEXT (_fun _GLenum _GLuint
+                                       -> _void))
+
+(define-cgl glGenRenderbuffersEXT (_fun _GLsizei (txt : (_ptr o _GLuint))
+                                        -> _void
+                                        -> txt))
+(define-cgl glBindRenderbufferEXT (_fun _GLenum _GLuint
+                                        -> _void))
+(define-cgl glRenderbufferStorageEXT (_fun _GLenum _GLenum _GLsizei _GLsizei
+                                           -> _void))
+(define-cgl glFramebufferRenderbufferEXT (_fun _GLenum _GLenum _GLenum _GLuint
+                                            -> _void))
+(define-cgl glReadPixels (_fun _GLint _GLint _GLsizei _GLsizei _GLenum _GLenum _pointer
+                               -> _void))
+
+(define GL_FRAMEBUFFER_EXT #x8D40)
+(define GL_TEXTURE_2D #x0DE1)
+(define GL_RENDERBUFFER_EXT #x8D41)
+(define GL_RGBA #x1908)
+(define GL_RGBA8 #x8058)
+(define GL_DEPTH_COMPONENT16 #x81A5)
+(define GL_UNSIGNED_BYTE #x1401)
+(define GL_COLOR_ATTACHMENT0_EXT #x8CE0)
+(define GL_DEPTH_ATTACHMENT_EXT #x8D00)
+
+(define kCGLPFAAllRenderers           1)
+(define kCGLPFADoubleBuffer           5)
+(define kCGLPFAStereo                 6)
+(define kCGLPFAAuxBuffers             7)
+(define kCGLPFAColorSize              8)
+(define kCGLPFAAlphaSize             11)
+(define kCGLPFADepthSize             12)
+(define kCGLPFAStencilSize           13)
+(define kCGLPFAAccumSize             14)
+(define kCGLPFAMinimumPolicy         51)
+(define kCGLPFAMaximumPolicy         52)
+(define kCGLPFAOffScreen             53)
+(define kCGLPFAFullScreen            54)
+(define kCGLPFASampleBuffers         55)
+(define kCGLPFASamples               56)
+(define kCGLPFAAuxDepthStencil       57)
+(define kCGLPFAColorFloat            58)
+(define kCGLPFAMultisample           59)
+(define kCGLPFASupersample           60)
+(define kCGLPFASampleAlpha           61)
+(define kCGLPFARendererID            70)
+(define kCGLPFASingleRenderer        71)
+(define kCGLPFANoRecovery            72)
+(define kCGLPFAAccelerated           73)
+(define kCGLPFAClosestPolicy         74)
+(define kCGLPFARobust                75)
+(define kCGLPFABackingStore          76)
+(define kCGLPFAMPSafe                78)
+(define kCGLPFAWindow                80)
+(define kCGLPFAMultiScreen           81)
+(define kCGLPFACompliant             83)
+(define kCGLPFADisplayMask           84)
+(define kCGLPFAPBuffer               90)
+(define kCGLPFARemotePBuffer         91)
+(define kCGLPFAAllowOfflineRenderers   96)
+(define kCGLPFAAcceleratedCompute    97)
+(define kCGLPFAOpenGLProfile         99)
+(define kCGLPFAVirtualScreenCount   128)
+
+(define dummy-cgl #f)
+(define current-cgl #f)
+
+(define cgl-context%
+  (let ([orig-gl-context% gl-context%])
+    (define gl-context%
+      (class orig-gl-context%
+        (init-field cgl touched)
+
+        (define/override (get-handle)
+          cgl)
+        
+        (define/override (do-call-as-current t)
+          (dynamic-wind
+              (lambda ()
+                (set-box! touched #t)
+                (atomically
+                 (CGLSetCurrentContext cgl)
+                 (set! current-cgl cgl)))
+              t
+              (lambda () 
+                (atomically
+                 (CGLSetCurrentContext dummy-cgl)
+                 (set! current-cgl #f)))))
+
+        (define/override (do-swap-buffers)
+          (void))
+
+        (super-new)))
+    gl-context%))
+    
+
+(define cgl-bitmap%
+  (let ([orig-bitmap% bitmap%])
+    (define bitmap%
+      (class orig-bitmap%
+        (init _cgl w h)
+        (super-make-object w h)
+
+        (define cgl _cgl)
+        (define width w)
+        (define height h)
+
+        (define bstr (make-bytes (* w h 4)))
+        (define row-bstr (make-bytes (* w w)))
+
+        (define touched (box #f))
+        
+        (define ctx (make-object cgl-context% cgl touched))
+
+        (define/override (get-bitmap-gl-context)
+          ctx)
+
+        (define/override (get-cairo-surface)
+          (surface-flush)
+          (super get-cairo-surface))
+
+        (define/override (surface-flush)
+          (when (version-10.7-or-later?)
+            (define s (super get-cairo-surface))
+            (atomically
+             (CGLSetCurrentContext cgl)
+             (glReadPixels 0 0 width height GL_RGBA GL_UNSIGNED_BYTE bstr)
+             (CGLSetCurrentContext (or current-cgl dummy-cgl)))
+            (cond
+             [(system-big-endian?)
+              ;; need ARGB
+              (for ([i (in-range 0 (* width height 4) 4)])
+                (define a (bytes-ref bstr (+ i 3)))
+                (bytes-set! bstr (+ i 1) (bytes-ref bstr i))
+                (bytes-set! bstr (+ i 2) (bytes-ref bstr (+ i 1)))
+                (bytes-set! bstr (+ i 3) (bytes-ref bstr (+ i 2)))
+                (bytes-set! bstr i a))]
+             [else
+              ;; need GBRA
+              (for ([i (in-range 0 (* width height 4) 4)])
+                (define g (bytes-ref bstr i))
+                (bytes-set! bstr i (bytes-ref bstr (+ i 2)))
+                (bytes-set! bstr (+ i 2) g))])          
+            ;; flip upside-down
+            (for ([i (in-range (quotient height 2))])
+              (define above-row (ptr-add bstr (* 4 i width)))
+              (define below-row (ptr-add bstr (* 4 (- height i) width)))
+              (memcpy row-bstr above-row (* 4 width))
+              (memcpy above-row below-row (* 4 width))
+              (memcpy below-row row-bstr (* 4 width)))
+            ;; assuming that stride = width
+            (memcpy (cairo_image_surface_get_data s) bstr (* width height 4)))
+          (super surface-flush))
+
+        (define/override (release-bitmap-storage)
+          (set! ctx #f)
+          (super release-bitmap-storage))))
+    bitmap%))
+
+(define (create-gl-bitmap w h conf)
+  (let* ([share-context (send conf get-share-context)]
+         [context-handle (if share-context (send share-context get-handle) #f)]
+         [fmt (CGLChoosePixelFormat
+               (append
+                (list kCGLPFASampleAlpha
+                      kCGLPFAColorSize 32)
+                (if (version-10.7-or-later?)
+                    null ; must use framebuffers
+                    (list kCGLPFAOffScreen))
+                (if (send conf get-stereo) (list kCGLPFAStereo) null)
+                (list
+                 kCGLPFADepthSize (send conf get-depth-size)
+                 kCGLPFAStencilSize (send conf get-stencil-size))
+                (let ([as (send conf get-accum-size)])
+                  (if (or (version-10.7-or-later?) ; deprecated in 10.7 and later
+                          (zero? as))
+                      null
+                      (list kCGLPFAAccumSize as)))
+                (let ([ms (send conf get-multisample-size)])
+                  (if (zero? ms)
+                      null
+                      (list kCGLPFASampleBuffers 1
+                            kCGLPFASamples ms)))
+                (list 0)))])
+    (and fmt
+         (let ([cgl (CGLCreateContext fmt context-handle)]
+               [d-cgl (or dummy-cgl
+                          (let ([d (CGLCreateContext fmt #f)])
+                            (when d
+                              (set! dummy-cgl d)
+                              d)))])
+           (and cgl
+                d-cgl
+                (let ([bm (make-object cgl-bitmap% cgl w h #f #t)])
+                  (and (send bm ok?)
+                       (let ([s (send bm get-cairo-surface)])
+                         (and (cond
+                               [(version-10.7-or-later?)
+                                (atomically
+                                 (CGLSetCurrentContext cgl)
+
+                                 (define fb (glGenFramebuffersEXT 1))
+                                 (glBindFramebufferEXT GL_FRAMEBUFFER_EXT fb)
+
+                                 (define rb (glGenRenderbuffersEXT 1))
+                                 (glBindRenderbufferEXT GL_RENDERBUFFER_EXT rb)
+                                 (glRenderbufferStorageEXT GL_RENDERBUFFER_EXT GL_RGBA8 w h)
+                                 (glFramebufferRenderbufferEXT GL_FRAMEBUFFER_EXT GL_COLOR_ATTACHMENT0_EXT
+                                                               GL_RENDERBUFFER_EXT rb)
+                                 
+                                 (unless (zero? (send conf get-depth-size))
+                                   (define rb2 (glGenRenderbuffersEXT 1))
+                                   (glBindRenderbufferEXT GL_RENDERBUFFER_EXT rb2)
+                                   (glRenderbufferStorageEXT GL_RENDERBUFFER_EXT GL_DEPTH_COMPONENT16 w h)
+                                   (glFramebufferRenderbufferEXT GL_FRAMEBUFFER_EXT GL_DEPTH_ATTACHMENT_EXT
+                                                                 GL_RENDERBUFFER_EXT rb2))
+
+                                 (CGLSetCurrentContext (or current-cgl dummy-cgl)))]
+                               [else
+                                (CGLSetOffScreen cgl w h
+                                                 (cairo_image_surface_get_stride s)
+                                                 (cairo_image_surface_get_data s))])
+                              bm)))))))))
+
--- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/procs.rkt
+++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/procs.rkt
@ -16,7 +16,7 @@
         "dc.rkt"
         "printer-dc.rkt"
         "menu-bar.rkt"
-         "agl.rkt"
+         "cgl.rkt"
         "sound.rkt"
         "keycode.rkt"
         "../../lock.rkt"
--- a/pkgs/sgl/examples/gears-bitmap.rkt
+++ b/pkgs/sgl/examples/gears-bitmap.rkt
@ -0,0 +1,25 @@
+#lang racket/base
+(require racket/draw
+         racket/gui/base
+         racket/class
+         "gears.rkt")
+
+(define w 400)
+(define h 400)
+
+(define bm (make-gl-bitmap w h (new gl-config%)))
+(define gears (new gears%
+                   [with-gl-context
+                    (lambda (thunk)
+                      (send (send (send bm make-dc) get-gl-context)
+                            call-as-current
+                            thunk))]
+                   [swap-gl-buffers void]
+                   [refresh void]
+                   [verbose? #f]))
+(send gears set-size w h)
+(void (send gears draw))
+
+(define dest (build-path (find-system-path 'temp-dir) "gears.png"))
+(when (send bm save-file dest 'png)
+  (printf "wrote to ~a\n" dest))
--- a/pkgs/sgl/examples/gears.rkt
+++ b/pkgs/sgl/examples/gears.rkt
@ -1,3 +1,4 @@
+#lang racket/base
 ;; $Id: gears.rkt,v 1.8 2005/01/12 12:49:10 mflatt Exp $
 ;;
 ;; This is a version of the venerable "gears" demo for PLT Scheme 200 using
@ -31,22 +32,24 @@
 ;;
 ;; Updated to newer sgl interface by Scott Owens

-
-(module gears mzscheme
-(require mred
-         mzlib/class
-         mzlib/math
+(require racket/draw
+         racket/class
+         racket/math
         sgl
         sgl/gl-vectors)

+(provide gears%)

 (define controls? #t)

-(define gears-canvas%
-  (class* canvas% ()
+(define gears%
+  (class object%
+    (init-field with-gl-context
+                swap-gl-buffers
+                refresh
+                verbose?)

-    (inherit refresh with-gl-context swap-gl-buffers get-parent
-	     get-top-level-window)
+    (super-new)

    (define rotation 0.0)

@ -60,6 +63,9 @@

    (define step? #f)

+    (define/public (ready?)
+      (and gear1 #t))
+
    (define/public (run)
      (set! step? #t)
      (refresh))
@ -232,25 +238,16 @@
            (gl-vertex (* r0 cos-angle) (* r0 sin-angle) half-width)))
        (gl-end)))

-    (define/private (report-no-gl)
-      (message-box "Gears"
-		   (string-append
-		    "There was an error initializing OpenGL. "
-		    "Maybe OpenGL is not supported on the current platform.")
-		   (get-top-level-window)
-		   '(ok stop))
-      (exit 1))
-
-    (define/override (on-size width height)
+    (define/public (set-size width height)
      (with-gl-context
-       #:fail (lambda () (report-no-gl))
       (lambda ()

-         (unless gear1
-           (printf "  RENDERER:   ~A\n" (gl-get-string 'renderer))
-           (printf "  VERSION:    ~A\n" (gl-get-string 'version))
-           (printf "  VENDOR:     ~A\n" (gl-get-string 'vendor))
-           (printf "  EXTENSIONS: ~A\n" (gl-get-string 'extensions)))
+         (when verbose?
+           (unless gear1
+             (printf "  RENDERER:   ~A\n" (gl-get-string 'renderer))
+             (printf "  VERSION:    ~A\n" (gl-get-string 'version))
+             (printf "  VENDOR:     ~A\n" (gl-get-string 'vendor))
+             (printf "  EXTENSIONS: ~A\n" (gl-get-string 'extensions))))

         (gl-viewport 0 0 width height)
         (gl-matrix-mode 'projection)
@ -296,23 +293,13 @@

           (gl-enable 'normalize))))
      (refresh))
-
-    (define sec (current-seconds))
-    (define frames 0)
    
-    (define/override (on-paint)
+    (define/public (draw)
      (when gear1
-	(when (>= (- (current-seconds) sec) 5)
-	  (send (get-parent) set-status-text (format "~a fps" (/ (exact->inexact frames) 5)))
-	  (set! sec (current-seconds))
-	  (set! frames 0))
-	(set! frames (add1 frames))
-        
 	(when step?
 	  ;; TODO: Don't increment this infinitely.
 	  (set! rotation (+ 2.0 rotation)))
 	(with-gl-context
-         #:fail (lambda () (report-no-gl))
 	 (lambda ()

 	   (gl-clear-color 0.0 0.0 0.0 0.0)
@ -344,35 +331,83 @@
 	   (gl-pop-matrix)

 	   (swap-gl-buffers)
-	   (gl-flush)))
-	(when step?
-	  (set! step? #f)
-	  (queue-callback (lambda x (send this run)) #f))))
+	   (gl-flush))))
+      (cond
+       [step?
+        (set! step? #f)
+        #t]
+       [else #f]))))

-    (super-instantiate () (style '(gl no-autoclear)))))
-(define (f)
-  (let* ((f (make-object frame% "gears.rkt" #f))
-         (c (instantiate gears-canvas% (f) (min-width 300) (min-height 300))))
+(module+ main
+  (require racket/gui/base)
+  
+  (define gears-canvas%
+    (class* canvas% ()
+      (inherit refresh with-gl-context swap-gl-buffers get-parent
+               get-top-level-window)
+
+      (define gears (new gears%
+                         [with-gl-context
+                          (lambda (thunk)
+                            (with-gl-context
+                             #:fail (lambda () (report-no-gl))
+                             thunk))]
+                         [swap-gl-buffers
+                          (lambda () (swap-gl-buffers))]
+                         [refresh
+                          (lambda () (refresh))]
+                         [verbose? #t]))
+
+      (define/public (get-gears) gears)
+      
+      (super-new [style '(gl no-autoclear)])
+
+      (define/private (report-no-gl)
+        (message-box "Gears"
+                     (string-append
+                      "There was an error initializing OpenGL. "
+                      "Maybe OpenGL is not supported on the current platform.")
+                     (get-top-level-window)
+                     '(ok stop))
+        (exit 1))
+
+      (define/override (on-size width height)
+        (send gears set-size width height))
+
+      (define sec (current-seconds))
+      (define frames 0)
+      
+      (define/override (on-paint)
+        (when (send gears ready?)
+          (when (>= (- (current-seconds) sec) 5)
+            (send (get-parent) set-status-text (format "~a fps" (/ (exact->inexact frames) 5)))
+            (set! sec (current-seconds))
+            (set! frames 0))
+          (set! frames (add1 frames))
+          
+          (when (send gears draw)
+            (queue-callback (lambda x (send gears run)) #f))))))
+
+  (let* ((f (new frame% [label "gears.rkt"]))
+         (c (new gears-canvas% (parent f) (min-width 300) (min-height 300))))
+    (define g (send c get-gears))
    (send f create-status-line)
    (when controls?
      (let ((h (instantiate horizontal-panel% (f)
                 (alignment '(center center)) (stretchable-height #f))))
        (instantiate button%
-          ("Start" h (lambda (b e) (send b enable #f) (send c run)))
+          ("Start" h (lambda (b e) (send b enable #f) (send g run)))
          (stretchable-width #t) (stretchable-height #t))
        (let ((h (instantiate horizontal-panel% (h)
                   (alignment '(center center)))))
-          (instantiate button% ("Left" h (lambda x (send c move-left)))
+          (instantiate button% ("Left" h (lambda x (send g move-left)))
            (stretchable-width #t))
          (let ((v (instantiate vertical-panel% (h)
                     (alignment '(center center)) (stretchable-width #f))))
-            (instantiate button% ("Up" v (lambda x (send c move-up)))
+            (instantiate button% ("Up" v (lambda x (send g move-up)))
              (stretchable-width #t))
-            (instantiate button% ("Down" v (lambda x (send c move-down)))
+            (instantiate button% ("Down" v (lambda x (send g move-down)))
              (stretchable-width #t)))
-          (instantiate button% ("Right" h (lambda x (send c move-right)))
+          (instantiate button% ("Right" h (lambda x (send g move-right)))
            (stretchable-width #t)))))
    (send f show #t)))
-  (f)
-)
-;;eof