win32: canvas gl, almost

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

@@ -579,14 +579,16 @@
        #t)
      (define/public (on-combo-select i) (void))
 
+     (define clear-bg? (and (not (memq 'transparent canvas-style)) 
+                            (not (memq 'no-autoclear canvas-style))))
      (define bg-col (make-object color% "white"))
      (define/public (get-canvas-background) (if (memq 'transparent canvas-style)
                                                 #f
                                                 bg-col))
      (define/public (set-canvas-background col) (set! bg-col col))
+     (define/public (get-canvas-background-for-backing) (and clear-bg? bg-col))
      (define/public (get-canvas-background-for-clearing) 
-       (and (not (memq 'transparent canvas-style)) 
+       (and clear-bg?
-            (not (memq 'no-autoclear canvas-style)) 
             bg-col))
 
      (define/public (reject-partial-update r)

collects/mred/private/wx/common/backing-dc.rkt

@@ -38,8 +38,7 @@
     (inherit call-with-cr-lock
              internal-get-bitmap
              internal-set-bitmap
-             reset-cr
+             reset-cr)
-             erase)
 
     (super-new)
 
@@ -57,6 +56,7 @@
     (define retained-cr #f)
     (define retained-counter 0)
     (define needs-flush? #f)
+    (define nada? #t)
 
     ;; called with a procedure that is applied to a bitmap;
     ;;  returns #f if there's nothing to flush
@@ -64,7 +64,8 @@
       (cond
        [(not retained-cr) #f]
        [(positive? retained-counter) 
-        (proc (internal-get-bitmap)) 
+        (unless nada?
+          (proc (internal-get-bitmap)))
         #t]
        [else 
         (reset-backing-retained proc)
@@ -113,9 +114,14 @@
               cr))))
 
     (define/override (release-cr cr)
+      (set! nada? #f)
       (when (zero? flush-suspends)
         (queue-backing-flush)))
 
+    (define/override (erase)
+      (super erase)
+      (set! nada? #t))
+
     (define flush-suspends 0)
     (define req #f)
 

collects/mred/private/wx/common/canvas-mixin.rkt

@@ -120,7 +120,7 @@
              on-paint
              queue-backing-flush
              get-dc
-             get-canvas-background)
+             get-canvas-background-for-backing)
     
     ;; Avoid multiple queued paints, and also allow cancel
     ;; of queued paint:
@@ -146,7 +146,7 @@
             (send dc suspend-flush)
             (send dc ensure-ready)
             (send dc erase) ; start with a clean slate
-            (let ([bg (get-canvas-background)])
+            (let ([bg (get-canvas-background-for-backing)])
               (when bg 
                 (let ([old-bg (send dc get-background)])
                   (send dc set-background bg)

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

@@ -497,6 +497,7 @@
                                                 #f
                                                 bg-col))
      (define/public (set-canvas-background col) (set! bg-col col))
+     (define/public (get-canvas-background-for-backing) (and clear-bg? bg-col))
      (define/public (get-canvas-background-for-clearing) 
        ;; called in event-dispatch mode
        (if clear-bg?

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

@@ -75,7 +75,7 @@
            x y w h
            style
            [ignored-name #f]
-           [gl-config #f])
+           [gl-conf #f])
 
      (inherit get-hwnd
               get-client-size
@@ -156,13 +156,16 @@
          (let* ([ps (malloc 128)]
                 [hdc (BeginPaint w ps)])
            (unless (positive? paint-suspended)
-             (let* ([hbrush (if transparent?
+             (let* ([hbrush (if no-autoclear?
-                                background-hbrush
+                                #f
-                                (CreateSolidBrush bg-colorref))])
+                                (if transparent?
-               (let ([r (GetClientRect canvas-hwnd)])
+                                    background-hbrush
-                 (FillRect hdc r hbrush))
+                                    (CreateSolidBrush bg-colorref)))])
-               (unless transparent?
+               (when hbrush
-                 (DeleteObject hbrush))
+                 (let ([r (GetClientRect canvas-hwnd)])
+                   (FillRect hdc r hbrush))
+                 (unless transparent?
+                   (DeleteObject hbrush)))
                (unless (do-backing-flush this dc hdc)
                  (queue-paint))))
            (EndPaint hdc ps))
@@ -200,6 +203,9 @@
 
      (define/public (get-dc) dc)
 
+     (define gl-config gl-conf)
+     (define/public (get-gl-config) gl-config)
+
      (define/override (on-resized)
        (reset-dc))
 
@@ -262,12 +268,16 @@
         (unless (zero? paint-suspended)
           (set! paint-suspended (sub1 paint-suspended)))))
 
+     (define no-autoclear? (memq 'no-autoclear style))
      (define transparent? (memq 'transparent style))
      (define bg-col (make-object color% "white"))
      (define bg-colorref #xFFFFFF)
      (define/public (get-canvas-background) (if transparent?
                                                 #f
                                                 bg-col))
+     (define/public (get-canvas-background-for-backing) (and (not transparent?)
+                                                             (not no-autoclear?)
+                                                             bg-col))
      (define/public (set-canvas-background col)
        (atomically
         (set! bg-col col)

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

@@ -3,6 +3,7 @@
          racket/class
          "utils.rkt"
          "types.rkt"
+         "gl-context.rkt"
 	 "../../lock.rkt"
          "../common/backing-dc.rkt"
          "../common/delay.rkt"
@@ -59,6 +60,16 @@
 
     (super-new)
 
+    (define gl #f)
+    (define/override (get-gl-context)
+      (or gl
+          (let ([v (create-gl-context (GetDC (send canvas get-client-hwnd))
+                                      (send canvas get-gl-config)
+                                      #f)])
+	    (when v (set! gl v))
+	    v)))
+      
+
     (define/override (make-backing-bitmap w h)
       (if (send canvas get-canvas-background)
           (make-object win32-bitmap% w h (send canvas get-hwnd))

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

@@ -1,11 +1,139 @@
-#lang scheme/base
+#lang racket/base
-(require scheme/class
+(require racket/class
-          "../../syntax.rkt")
+         ffi/unsafe
+         ffi/unsafe/define
+         ffi/unsafe/alloc
+         racket/draw/gl-config
+         (prefix-in draw: racket/draw/gl-context)
+         "types.rkt"
+         "utils.rkt")
 
-(provide gl-context%)
+(provide create-gl-context)
 
-(defclass gl-context% object%
+(define opengl32-lib (ffi-lib "opengl32.dll"))
-  (def/public-unimplemented call-as-current)
+
-  (def/public-unimplemented swap-buffers)
+(define-ffi-definer define-opengl32 opengl32-lib)
-  (def/public-unimplemented ok?)
+
-  (super-new))
+(define _HGLRC (_cpointer/null 'HGLRC))
+
+(define-cstruct _PIXELFORMATDESCRIPTOR
+  ([nSize _WORD]
+   [nVersion _WORD]
+   [dwFlags _DWORD]
+   [iPixelType _BYTE]
+   [cColorBits _BYTE]
+   [cRedBits _BYTE]
+   [cRedShift _BYTE]
+   [cGreenBits _BYTE]
+   [cGreenShift _BYTE]
+   [cBlueBits _BYTE]
+   [cBlueShift _BYTE]
+   [cAlphaBits _BYTE]
+   [cAlphaShift _BYTE]
+   [cAccumBits _BYTE]
+   [cAccumRedBits _BYTE]
+   [cAccumGreenBits _BYTE]
+   [cAccumBlueBits _BYTE]
+   [cAccumAlphaBits _BYTE]
+   [cDepthBits _BYTE]
+   [cStencilBits _BYTE]
+   [cAuxBuffers _BYTE]
+   [iLayerType _BYTE]
+   [bReserved _BYTE]
+   [dwLayerMask _DWORD]
+   [dwVisibleMask _DWORD]
+   [dwDamageMask _DWORD]))
+
+(define-gdi32 ChoosePixelFormat (_wfun _HDC _PIXELFORMATDESCRIPTOR-pointer -> _int))
+(define-gdi32 SetPixelFormat (_wfun _HDC _int _PIXELFORMATDESCRIPTOR-pointer -> _BOOL))
+(define-gdi32 DescribePixelFormat (_wfun _HDC _int _UINT _PIXELFORMATDESCRIPTOR-pointer -> (r : _int)
+                                         -> (if (zero? r)
+                                                (failed 'DescribePixelFormat)
+                                                r)))
+(define-gdi32 SwapBuffers (_wfun _HDC -> _BOOL))
+
+(define-opengl32 wglDeleteContext (_wfun _HGLRC -> (r : _BOOL)
+                                         -> (unless r (failed 'wglDeleteContext)))
+  #:wrap (deallocator))
+(define-opengl32 wglCreateContext (_wfun _HDC -> _HGLRC)
+  #:wrap (allocator wglDeleteContext))
+
+(define-opengl32 wglMakeCurrent (_wfun _HDC _HGLRC -> _BOOL))
+
+;; ----------------------------------------
+
+(define gl-context% 
+  (class draw:gl-context%
+    (init-field [hglrc hglrc]
+                [hdc hdc])
+
+    (define/override (draw:do-call-as-current t)
+      (dynamic-wind
+          (lambda ()
+            (wglMakeCurrent hdc hglrc))
+          t
+          (lambda ()
+            (wglMakeCurrent #f #f))))
+        
+    (define/override (draw:do-swap-buffers)
+      (SwapBuffers hdc))
+    
+    (super-new)))
+
+;; ----------------------------------------
+
+(define PFD_DOUBLEBUFFER            #x00000001)
+(define PFD_STEREO                  #x00000002)
+(define PFD_DRAW_TO_WINDOW          #x00000004)
+(define PFD_DRAW_TO_BITMAP          #x00000008)
+(define PFD_SUPPORT_GDI             #x00000010)
+(define PFD_SUPPORT_OPENGL          #x00000020)
+(define PFD_NEED_PALETTE            #x00000080)
+(define PFD_NEED_SYSTEM_PALETTE     #x00000100)
+(define PFD_GENERIC_ACCELERATED     #x00001000)
+(define PFD_TYPE_RGBA    0)
+(define PFD_MAIN_PLANE   0)
+
+(define (create-gl-context hdc config offscreen?)
+  (let* ([config (or config (new gl-config%))]
+         [accum (send config get-accum-size)]
+         [pfd
+          (make-PIXELFORMATDESCRIPTOR
+           (ctype-sizeof _PIXELFORMATDESCRIPTOR)
+           1 ; version
+           (bitwise-ior
+            PFD_SUPPORT_OPENGL
+            (if (send config get-stereo) PFD_STEREO 0)
+            (if (and (not offscreen?) 
+                     (send config get-double-buffered))
+                PFD_DOUBLEBUFFER
+                0)
+            (if offscreen?
+                (bitwise-ior PFD_DRAW_TO_BITMAP
+                             PFD_SUPPORT_GDI)
+                (bitwise-ior PFD_DRAW_TO_WINDOW)))
+           PFD_TYPE_RGBA ; color type
+           (if offscreen? 32 24) ; prefered color depth
+           0 0 0 0 0 0 ; color bits (ignored)
+           0 ; no alpha buffer
+           0 ; alpha bits (ignored)
+           (* 4 accum) ; no accumulation buffer
+           accum accum accum accum ; accum bits
+           (if offscreen? 32 (send config get-depth-size)) ; depth buffer
+           (send config get-stencil-size) ; stencil buffer
+           0 ; no auxiliary buffers
+           PFD_MAIN_PLANE ; main layer
+           0 ; reserved 
+           0 0 0 ; no layer, visible, damage masks
+           )]
+         [pixelFormat (ChoosePixelFormat hdc pfd)])
+    (and (not (zero? pixelFormat))
+         (SetPixelFormat hdc pixelFormat pfd)
+         (begin
+           (DescribePixelFormat hdc pixelFormat (ctype-sizeof _PIXELFORMATDESCRIPTOR) pfd)
+           (when (not (zero? (bitwise-and (PIXELFORMATDESCRIPTOR-dwFlags pfd)
+                                          PFD_NEED_PALETTE)))
+             (log-error "don't know how to create a GL palette, yet"))
+           (let ([hglrc (wglCreateContext hdc)])
+             (and hglrc
+                  (new gl-context% [hglrc hglrc] [hdc hdc])))))))

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

@@ -537,7 +537,8 @@
   (define/public (send-leaves mk)
     (set! mouse-in? #f)
     (let ([e (mk 'leave)])
-      (if (eq? (current-eventspace) (get-eventspace))
+      (if (eq? (current-thread) 
+               (eventspace-handler-thread (get-eventspace)))
           (handle-mouse-event (get-client-hwnd) 0 0 e)
           (queue-window-event this
                               (lambda () (dispatch-on-event/sync e))))))

collects/racket/draw/local.rkt

@@ -34,6 +34,7 @@
   ;; dc-backend<%>
   call-with-cr-lock
   get-cr
+  release-cr
   end-cr
   reset-cr
   flush-cr