141 lines
4.7 KiB
Racket
141 lines
4.7 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)
|
|
"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 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])))))))
|