151 lines
4.9 KiB
Racket
151 lines
4.9 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
ffi/unsafe
|
|
ffi/unsafe/define
|
|
ffi/unsafe/alloc
|
|
"../../lock.rkt"
|
|
racket/draw/unsafe/cairo
|
|
racket/draw/private/local
|
|
racket/draw/private/gl-context
|
|
racket/draw/private/gl-config
|
|
racket/draw/private/bitmap)
|
|
|
|
(provide (protect-out create-gl-bitmap))
|
|
|
|
(define agl-lib
|
|
(ffi-lib "/System/Library/Frameworks/AGL.framework/AGL"))
|
|
|
|
(define-ffi-definer define-agl agl-lib)
|
|
|
|
(define _GLsizei _int)
|
|
(define _GLint _int)
|
|
(define _GLboolean _bool)
|
|
(define _AGLPixelFormat (_cpointer/null 'AGLPixelFormat))
|
|
(define _AGLContext (_cpointer/null 'AGLContext))
|
|
|
|
(define-agl aglChoosePixelFormat (_fun _pointer _GLint (_list i _GLint) -> _AGLPixelFormat))
|
|
(define-agl aglDestroyContext (_fun _AGLContext -> _GLboolean)
|
|
#:wrap (deallocator))
|
|
(define-agl aglCreateContext (_fun _AGLPixelFormat _AGLContext -> _AGLContext)
|
|
#:wrap (allocator aglDestroyContext))
|
|
|
|
(define-agl aglSetOffScreen (_fun _AGLContext _GLsizei _GLsizei _GLsizei _pointer
|
|
-> _GLboolean))
|
|
|
|
(define-agl aglSetCurrentContext (_fun _AGLContext -> _GLboolean))
|
|
|
|
(define AGL_NONE 0)
|
|
(define AGL_BUFFER_SIZE 2)
|
|
(define AGL_LEVEL 3)
|
|
(define AGL_RGBA 4)
|
|
(define AGL_DOUBLEBUFFER 5)
|
|
(define AGL_STEREO 6)
|
|
(define AGL_AUX_BUFFERS 7)
|
|
(define AGL_RED_SIZE 8)
|
|
(define AGL_GREEN_SIZE 9)
|
|
(define AGL_BLUE_SIZE 10)
|
|
(define AGL_ALPHA_SIZE 11)
|
|
(define AGL_DEPTH_SIZE 12)
|
|
(define AGL_STENCIL_SIZE 13)
|
|
(define AGL_ACCUM_RED_SIZE 14)
|
|
(define AGL_ACCUM_GREEN_SIZE 15)
|
|
(define AGL_ACCUM_BLUE_SIZE 16)
|
|
(define AGL_ACCUM_ALPHA_SIZE 17)
|
|
(define AGL_PIXEL_SIZE 50)
|
|
(define AGL_OFFSCREEN 53)
|
|
(define AGL_SAMPLE_BUFFERS_ARB 55)
|
|
(define AGL_SAMPLES_ARB 56)
|
|
(define AGL_AUX_DEPTH_STENCIL 57)
|
|
(define AGL_COLOR_FLOAT 58)
|
|
(define AGL_MULTISAMPLE 59)
|
|
(define AGL_SUPERSAMPLE 60)
|
|
(define AGL_SAMPLE_ALPHA 61)
|
|
|
|
(define dummy-agl #f)
|
|
(define current-agl #f)
|
|
|
|
(define agl-context%
|
|
(let ([orig-gl-context% gl-context%])
|
|
(define gl-context%
|
|
(class orig-gl-context%
|
|
(init-field agl)
|
|
|
|
(define/override (do-call-as-current t)
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(atomically
|
|
(aglSetCurrentContext agl)
|
|
(set! current-agl agl)))
|
|
t
|
|
(lambda ()
|
|
(atomically
|
|
(aglSetCurrentContext dummy-agl)
|
|
(set! current-agl #f)))))
|
|
|
|
(define/override (do-swap-buffers)
|
|
(void))
|
|
|
|
(super-new)))
|
|
gl-context%))
|
|
|
|
|
|
(define agl-bitmap%
|
|
(let ([orig-bitmap% bitmap%])
|
|
(define bitmap%
|
|
(class orig-bitmap%
|
|
(init agl)
|
|
(super-new)
|
|
|
|
(define ctx (make-object agl-context% agl))
|
|
|
|
(define/override (get-bitmap-gl-context)
|
|
ctx)
|
|
|
|
(define/override (release-bitmap-storage)
|
|
(set! ctx #f)
|
|
(super release-bitmap-storage))))
|
|
bitmap%))
|
|
|
|
(define (create-gl-bitmap w h conf)
|
|
(let ([fmt (aglChoosePixelFormat
|
|
#f
|
|
0
|
|
(append
|
|
(list AGL_RGBA
|
|
AGL_PIXEL_SIZE 32
|
|
AGL_OFFSCREEN)
|
|
(if (send conf get-stereo) (list AGL_STEREO) null)
|
|
(list
|
|
AGL_DEPTH_SIZE (send conf get-depth-size)
|
|
AGL_STENCIL_SIZE (send conf get-stencil-size))
|
|
(let ([as (send conf get-accum-size)])
|
|
(if (zero? as)
|
|
null
|
|
(list AGL_ACCUM_RED_SIZE as
|
|
AGL_ACCUM_GREEN_SIZE as
|
|
AGL_ACCUM_BLUE_SIZE as
|
|
AGL_ACCUM_ALPHA_SIZE as)))
|
|
(let ([ms (send conf get-multisample-size)])
|
|
(if (zero? ms)
|
|
null
|
|
(list AGL_SAMPLE_BUFFERS_ARB 1
|
|
AGL_SAMPLES_ARB ms)))
|
|
(list AGL_NONE)))])
|
|
(and fmt
|
|
(let ([agl (aglCreateContext fmt #f)]
|
|
[d-agl (or dummy-agl
|
|
(let ([d (aglCreateContext fmt #f)])
|
|
(when d
|
|
(set! dummy-agl d)
|
|
d)))])
|
|
(and agl
|
|
d-agl
|
|
(let ([bm (make-object agl-bitmap% agl w h #f #t)])
|
|
(and (send bm ok?)
|
|
(let ([s (send bm get-cairo-surface)])
|
|
(and (aglSetOffScreen agl w h
|
|
(cairo_image_surface_get_stride s)
|
|
(cairo_image_surface_get_data s))
|
|
bm)))))))))
|
|
|