From b9e6ffe18c651d58bd32c8fc50f171edd5acf878 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 13 Oct 2010 14:43:54 -0600 Subject: [PATCH] win32: canvas gl, almost --- collects/mred/private/wx/cocoa/canvas.rkt | 6 +- .../mred/private/wx/common/backing-dc.rkt | 12 +- .../mred/private/wx/common/canvas-mixin.rkt | 4 +- collects/mred/private/wx/gtk/canvas.rkt | 1 + collects/mred/private/wx/win32/canvas.rkt | 26 +++- collects/mred/private/wx/win32/dc.rkt | 11 ++ collects/mred/private/wx/win32/gl-context.rkt | 146 ++++++++++++++++-- collects/mred/private/wx/win32/window.rkt | 3 +- collects/racket/draw/local.rkt | 1 + 9 files changed, 185 insertions(+), 25 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 34b8853b46..3c9f42d613 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/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)) - (not (memq 'no-autoclear canvas-style)) + (and clear-bg? bg-col)) (define/public (reject-partial-update r) diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt index c77f6173be..7b848a5593 100644 --- a/collects/mred/private/wx/common/backing-dc.rkt +++ b/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 - erase) + reset-cr) (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) diff --git a/collects/mred/private/wx/common/canvas-mixin.rkt b/collects/mred/private/wx/common/canvas-mixin.rkt index cd1a32805c..2e428a413b 100644 --- a/collects/mred/private/wx/common/canvas-mixin.rkt +++ b/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) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 5d82ff9d75..5a15443320 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/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? diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 24722e4c54..41a3ab78fc 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/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? - background-hbrush - (CreateSolidBrush bg-colorref))]) - (let ([r (GetClientRect canvas-hwnd)]) - (FillRect hdc r hbrush)) - (unless transparent? - (DeleteObject hbrush)) + (let* ([hbrush (if no-autoclear? + #f + (if transparent? + background-hbrush + (CreateSolidBrush bg-colorref)))]) + (when 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) diff --git a/collects/mred/private/wx/win32/dc.rkt b/collects/mred/private/wx/win32/dc.rkt index efdd082b4b..9c14dc1f33 100644 --- a/collects/mred/private/wx/win32/dc.rkt +++ b/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)) diff --git a/collects/mred/private/wx/win32/gl-context.rkt b/collects/mred/private/wx/win32/gl-context.rkt index ba5d78e00f..6aa27b532e 100644 --- a/collects/mred/private/wx/win32/gl-context.rkt +++ b/collects/mred/private/wx/win32/gl-context.rkt @@ -1,11 +1,139 @@ -#lang scheme/base -(require scheme/class - "../../syntax.rkt") +#lang racket/base +(require racket/class + 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% - (def/public-unimplemented call-as-current) - (def/public-unimplemented swap-buffers) - (def/public-unimplemented ok?) - (super-new)) +(define opengl32-lib (ffi-lib "opengl32.dll")) + +(define-ffi-definer define-opengl32 opengl32-lib) + +(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]))))))) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 24a00f023d..72a191ddee 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/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)))))) diff --git a/collects/racket/draw/local.rkt b/collects/racket/draw/local.rkt index e2ec46966b..0abe8094fd 100644 --- a/collects/racket/draw/local.rkt +++ b/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