307 lines
9.9 KiB
Racket
307 lines
9.9 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
ffi/unsafe
|
|
ffi/unsafe/define
|
|
ffi/unsafe/alloc
|
|
racket/draw/private/gl-config
|
|
(prefix-in draw: racket/draw/private/gl-context)
|
|
"../../lock.rkt"
|
|
"wndclass.rkt"
|
|
"const.rkt"
|
|
"types.rkt"
|
|
"utils.rkt")
|
|
|
|
(provide
|
|
(protect-out create-gl-context))
|
|
|
|
(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-opengl32 wglGetCurrentContext (_wfun -> _HGLRC))
|
|
(define-opengl32 wglGetCurrentDC (_wfun -> _HDC))
|
|
|
|
(define-opengl32 wglGetProcAddress (_wfun _string -> _fpointer))
|
|
|
|
(define tried-multisample? #f)
|
|
(define wglChoosePixelFormatARB #f)
|
|
|
|
(define looked-for-createcontextattribs? #f)
|
|
(define wglCreateContextAttribsARB #f)
|
|
|
|
(define looked-for-wglswapinternalext? #f)
|
|
(define wglSwapIntervalEXT #f)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define gl-context%
|
|
(class draw:gl-context%
|
|
(init-field [hglrc hglrc]
|
|
[hdc hdc])
|
|
|
|
(define/override (get-handle) hglrc)
|
|
|
|
(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 (call-with-context hdc hglrc f)
|
|
(atomically
|
|
(let ([old-hdc (wglGetCurrentDC)]
|
|
[old-hglrc (wglGetCurrentContext)])
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(wglMakeCurrent hdc hglrc))
|
|
f
|
|
(lambda ()
|
|
(wglMakeCurrent old-hdc old-hglrc))))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(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?
|
|
#:try-ms? [try-ms? (not offscreen?)])
|
|
(when try-ms? (unless tried-multisample? (init-multisample! config)))
|
|
(unless looked-for-createcontextattribs? (init-createcontextattribs! config))
|
|
(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) ; preferred 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
|
|
)]
|
|
[ms (send config get-multisample-size)]
|
|
[pixelFormat (or
|
|
(and try-ms?
|
|
wglChoosePixelFormatARB
|
|
(or (choose-multisample hdc config offscreen? ms)
|
|
(choose-multisample hdc config offscreen? 2)))
|
|
(ChoosePixelFormat hdc pfd))]
|
|
[share-context (send config get-share-context)]
|
|
[context-handle (if share-context (send share-context get-handle) #f)])
|
|
(and (not (zero? pixelFormat))
|
|
(and (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 (if wglCreateContextAttribsARB
|
|
(wglCreateContextAttribsARB hdc context-handle (vector 0))
|
|
(wglCreateContext hdc))])
|
|
(and hglrc
|
|
(begin
|
|
(when (send config get-sync-swap)
|
|
(call-with-context
|
|
hdc
|
|
hglrc
|
|
(lambda ()
|
|
(unless looked-for-wglswapinternalext?
|
|
(set! wglSwapIntervalEXT
|
|
(let ([f (wglGetProcAddress "wglSwapIntervalEXT")])
|
|
(and f
|
|
(function-ptr f (_wfun _int -> _void)))))
|
|
(set! looked-for-wglswapinternalext? #t))
|
|
(when wglSwapIntervalEXT
|
|
(wglSwapIntervalEXT 1)))))
|
|
(new gl-context% [hglrc hglrc] [hdc hdc])))))))))
|
|
|
|
(define (with-dummy-context config thunk)
|
|
;; To create a gl context, we need a separate window
|
|
;; (because you can't change a window's pixel format
|
|
;; after it is set).
|
|
;; So, create a dummy window to make a context to
|
|
;; try to do whatever needs doing.
|
|
(let ([hwnd (CreateWindowExW 0
|
|
"PLTFrame"
|
|
""
|
|
WS_POPUP
|
|
0 0 1 1
|
|
#f
|
|
#f
|
|
hInstance
|
|
#f)])
|
|
(when hwnd
|
|
(let ([hdc (GetDC hwnd)])
|
|
(let ([c (create-gl-context hdc config #f #:try-ms? #f)])
|
|
(when c
|
|
(call-with-context
|
|
(get-field hdc c)
|
|
(get-field hglrc c)
|
|
thunk)))
|
|
(ReleaseDC hwnd hdc)))))
|
|
|
|
(define (init-createcontextattribs! config)
|
|
;; look for wglCreateContextAttribsARB which is a beefed
|
|
;; up version of wglCreateContext
|
|
(set! looked-for-createcontextattribs? #t)
|
|
(with-dummy-context config
|
|
(lambda ()
|
|
(set! wglCreateContextAttribsARB
|
|
(let ([f (wglGetProcAddress "wglCreateContextAttribsARB")])
|
|
(and f
|
|
((allocator wglDeleteContext)
|
|
(function-ptr f (_wfun _HDC
|
|
_HGLRC
|
|
(_vector i _int)
|
|
-> _HGLRC)))))))))
|
|
|
|
(define (init-multisample! config)
|
|
;; To create a multisampled context, we need
|
|
;; wglChoosePixelFormatARB().
|
|
;; To look up wglChoosePixelFormatARB(), we need
|
|
;; an existing gl context.
|
|
(with-dummy-context config
|
|
(lambda ()
|
|
(set! wglChoosePixelFormatARB
|
|
(let ([f (wglGetProcAddress "wglChoosePixelFormatARB")])
|
|
(and f
|
|
(function-ptr f (_wfun _HDC
|
|
(_vector i _int)
|
|
(_vector i _float)
|
|
(_UINT = 1)
|
|
(formats : (_ptr o _int))
|
|
(num-formats : (_ptr o _UINT))
|
|
-> (r : _BOOL)
|
|
-> (and r formats))))))
|
|
(set! tried-multisample? #t))))
|
|
|
|
(define GL_TRUE 1)
|
|
(define GL_FALSE 0)
|
|
(define WGL_DRAW_TO_WINDOW_ARB #x2001)
|
|
(define WGL_DRAW_TO_BITMAP_ARB #x2002)
|
|
(define WGL_SUPPORT_OPENGL_ARB #x2010)
|
|
(define WGL_ACCELERATION_ARB #x2003)
|
|
(define WGL_FULL_ACCELERATION_ARB #x2027)
|
|
(define WGL_COLOR_BITS_ARB #x2014)
|
|
(define WGL_ALPHA_BITS_ARB #x201B)
|
|
(define WGL_DEPTH_BITS_ARB #x2022)
|
|
(define WGL_STENCIL_BITS_ARB #x2023)
|
|
(define WGL_DOUBLE_BUFFER_ARB #x2011)
|
|
(define WGL_SAMPLE_BUFFERS_ARB #x2041)
|
|
(define WGL_SAMPLES_ARB #x2042)
|
|
|
|
;; The multisampling substitute for ChoosePixelFormat:
|
|
(define (choose-multisample hdc config offscreen? ms)
|
|
(and
|
|
wglChoosePixelFormatARB
|
|
(wglChoosePixelFormatARB
|
|
hdc
|
|
(vector (if offscreen?
|
|
WGL_DRAW_TO_BITMAP_ARB
|
|
WGL_DRAW_TO_WINDOW_ARB)
|
|
GL_TRUE
|
|
WGL_SUPPORT_OPENGL_ARB
|
|
GL_TRUE
|
|
WGL_ACCELERATION_ARB
|
|
WGL_FULL_ACCELERATION_ARB
|
|
WGL_COLOR_BITS_ARB
|
|
24
|
|
WGL_ALPHA_BITS_ARB
|
|
8
|
|
WGL_DEPTH_BITS_ARB
|
|
(send config get-depth-size) ; 32 for offscreen?
|
|
WGL_STENCIL_BITS_ARB
|
|
(send config get-stencil-size)
|
|
WGL_DOUBLE_BUFFER_ARB
|
|
(if (and (not offscreen?)
|
|
(send config get-double-buffered))
|
|
GL_TRUE
|
|
GL_FALSE)
|
|
WGL_SAMPLE_BUFFERS_ARB
|
|
GL_TRUE
|
|
WGL_SAMPLES_ARB
|
|
ms
|
|
0
|
|
0)
|
|
(vector 0.0 0.0))))
|