suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

win32: canvas gl, almost

Browse Source
This commit is contained in:
Matthew Flatt 2010-10-13 14:43:54 -06:00
parent 1bddb120f9
commit b9e6ffe18c
9 changed files with 185 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/mred/private/wx/cocoa/canvas.rkt
View File

@ -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)

12
collects/mred/private/wx/common/backing-dc.rkt
View File

@ -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)

4
collects/mred/private/wx/common/canvas-mixin.rkt
View File

@ -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)

1
collects/mred/private/wx/gtk/canvas.rkt
View File

@ -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?

26
collects/mred/private/wx/win32/canvas.rkt
View File

@ -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)

11
collects/mred/private/wx/win32/dc.rkt
View File

@ -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))

146
collects/mred/private/wx/win32/gl-context.rkt
View File

@ -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])))))))

3
collects/mred/private/wx/win32/window.rkt
View File

@ -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))))))

1
collects/racket/draw/local.rkt
View File

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