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