189 lines
6.4 KiB
Racket
189 lines
6.4 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
ffi/unsafe
|
|
ffi/unsafe/define
|
|
ffi/unsafe/alloc
|
|
(prefix-in draw: racket/draw/private/gl-context)
|
|
racket/draw/private/gl-config
|
|
"types.rkt"
|
|
"utils.rkt")
|
|
|
|
(provide
|
|
(protect-out prepare-widget-gl-context
|
|
create-widget-gl-context
|
|
|
|
create-and-install-gl-context
|
|
get-gdk-pixmap
|
|
install-gl-context))
|
|
|
|
(define gdkglext-lib
|
|
(with-handlers ([exn:fail? (lambda (exn) #f)])
|
|
(ffi-lib "libgdkglext-x11-1.0" '("0"))))
|
|
(define gtkglext-lib
|
|
(with-handlers ([exn:fail? (lambda (exn) #f)])
|
|
(ffi-lib "libgtkglext-x11-1.0" '("0"))))
|
|
|
|
(define-ffi-definer define-gdkglext gdkglext-lib
|
|
#:default-make-fail make-not-available)
|
|
(define-ffi-definer define-gtkglext gtkglext-lib
|
|
#:default-make-fail make-not-available)
|
|
|
|
(define _GdkGLContext (_cpointer/null 'GdkGLContext))
|
|
(define _GdkGLDrawable (_cpointer 'GdkGLDrawable))
|
|
(define _GdkGLConfig (_cpointer 'GdkGLConfig))
|
|
(define _GdkGLPixmap _GdkGLDrawable)
|
|
(define _GdkPixmap _pointer)
|
|
|
|
(define-gdkglext gdk_gl_init (_fun (_ptr i _int)
|
|
(_ptr i _pointer)
|
|
-> _void)
|
|
#:fail (lambda () void))
|
|
|
|
(define-gtkglext gdk_gl_config_new (_fun (_list i _int) -> (_or-null _GdkGLConfig))
|
|
#:fail (lambda () (lambda args #f)))
|
|
(define-gtkglext gdk_gl_config_new_for_screen (_fun _GdkScreen (_list i _int) -> (_or-null _GdkGLConfig)))
|
|
|
|
(define-gtk gtk_widget_get_screen (_fun _GtkWidget -> _GdkScreen))
|
|
|
|
(define-gtkglext gtk_widget_set_gl_capability (_fun _GtkWidget
|
|
_GdkGLConfig
|
|
_GdkGLContext
|
|
_gboolean
|
|
_int
|
|
-> _gboolean)
|
|
#:fail (lambda () (lambda args #f)))
|
|
|
|
(define-gtkglext gtk_widget_get_gl_context (_fun _GtkWidget -> _GdkGLContext)
|
|
#:fail (lambda () (lambda args #f)))
|
|
(define-gtkglext gtk_widget_get_gl_window (_fun _GtkWidget -> _GdkGLDrawable))
|
|
|
|
(define-gdkglext gdk_gl_context_destroy (_fun _GdkGLContext -> _void)
|
|
#:wrap (deallocator))
|
|
|
|
(define-gdkglext gdk_gl_context_new (_fun _GdkGLDrawable _GdkGLContext _gboolean _int
|
|
-> _GdkGLContext)
|
|
#:wrap (allocator gdk_gl_context_destroy))
|
|
|
|
(define-gdkglext gdk_gl_drawable_gl_begin (_fun _GdkGLDrawable
|
|
_GdkGLContext
|
|
-> _gboolean))
|
|
(define-gdkglext gdk_gl_drawable_gl_end (_fun _GdkGLDrawable -> _void))
|
|
(define-gdkglext gdk_gl_drawable_swap_buffers (_fun _GdkGLDrawable -> _void))
|
|
|
|
(define-gdkglext gdk_pixmap_set_gl_capability (_fun _GdkPixmap _GdkGLConfig _pointer
|
|
-> _GdkGLPixmap))
|
|
|
|
(define GDK_GL_RGBA_TYPE 0)
|
|
|
|
(define GDK_GL_USE_GL 1)
|
|
(define GDK_GL_BUFFER_SIZE 2)
|
|
(define GDK_GL_LEVEL 3)
|
|
(define GDK_GL_RGBA 4)
|
|
(define GDK_GL_DOUBLEBUFFER 5)
|
|
(define GDK_GL_STEREO 6)
|
|
(define GDK_GL_AUX_BUFFERS 7)
|
|
(define GDK_GL_RED_SIZE 8)
|
|
(define GDK_GL_GREEN_SIZE 9)
|
|
(define GDK_GL_BLUE_SIZE 10)
|
|
(define GDK_GL_ALPHA_SIZE 11)
|
|
(define GDK_GL_DEPTH_SIZE 12)
|
|
(define GDK_GL_STENCIL_SIZE 13)
|
|
(define GDK_GL_ACCUM_RED_SIZE 14)
|
|
(define GDK_GL_ACCUM_GREEN_SIZE 15)
|
|
(define GDK_GL_ACCUM_BLUE_SIZE 16)
|
|
(define GDK_GL_ACCUM_ALPHA_SIZE 17)
|
|
(define GDK_GL_SAMPLE_BUFFERS 100000)
|
|
(define GDK_GL_SAMPLES 100001)
|
|
(define GDK_GL_ATTRIB_LIST_NONE 0)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (config->GdkGLConfig d conf can-double?)
|
|
(gdk_gl_config_new (append
|
|
(list GDK_GL_RGBA)
|
|
(if can-double?
|
|
(if (send conf get-double-buffered) (list GDK_GL_DOUBLEBUFFER) null)
|
|
null)
|
|
(if (send conf get-stereo) (list GDK_GL_STEREO) null)
|
|
(list
|
|
GDK_GL_DEPTH_SIZE (send conf get-depth-size)
|
|
GDK_GL_STENCIL_SIZE (send conf get-stencil-size)
|
|
GDK_GL_ACCUM_RED_SIZE (send conf get-accum-size)
|
|
GDK_GL_ACCUM_GREEN_SIZE (send conf get-accum-size)
|
|
GDK_GL_ACCUM_BLUE_SIZE (send conf get-accum-size)
|
|
GDK_GL_ACCUM_ALPHA_SIZE (send conf get-accum-size))
|
|
#;
|
|
(list GDK_GL_SAMPLES (send conf get-multisample-size))
|
|
(list GDK_GL_ATTRIB_LIST_NONE))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define gl-context%
|
|
(class draw:gl-context%
|
|
(init-field [gl gl]
|
|
[drawable drawable])
|
|
|
|
(define/override (draw:do-call-as-current t)
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(gdk_gl_drawable_gl_begin drawable gl))
|
|
t
|
|
(lambda ()
|
|
(gdk_gl_drawable_gl_end drawable))))
|
|
|
|
(define/override (draw:do-swap-buffers)
|
|
(gdk_gl_drawable_swap_buffers drawable))
|
|
|
|
(super-new)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define inited? #f)
|
|
(define (init!)
|
|
(unless inited?
|
|
(set! inited? #t)
|
|
(gdk_gl_init 0 #f)))
|
|
|
|
(define (prepare-widget-gl-context gtk config)
|
|
(init!)
|
|
(let ([config (config->GdkGLConfig #f ; (gtk_widget_get_screen gtk)
|
|
(or config
|
|
(new gl-config%))
|
|
#t)])
|
|
(when config
|
|
(gtk_widget_set_gl_capability gtk
|
|
config
|
|
#f
|
|
#t
|
|
0))))
|
|
|
|
(define (create-widget-gl-context gtk)
|
|
(init!)
|
|
(let ([gl (gtk_widget_get_gl_context gtk)])
|
|
(and gl
|
|
(new gl-context%
|
|
[gl gl]
|
|
[drawable (gtk_widget_get_gl_window gtk)]))))
|
|
|
|
|
|
(define-local-member-name
|
|
get-gdk-pixmap
|
|
install-gl-context)
|
|
|
|
(define (create-and-install-gl-context bm config)
|
|
(init!)
|
|
(let ([config (config->GdkGLConfig #f config #f)])
|
|
(when config
|
|
(let ([gdkpx (send bm get-gdk-pixmap)])
|
|
(let ([glpx (gdk_pixmap_set_gl_capability gdkpx config #f)])
|
|
(and glpx
|
|
(let ([gl
|
|
;; currently uses "indirect" mode --- can we
|
|
;; reliably use direct in some environments?
|
|
(gdk_gl_context_new glpx #f #f GDK_GL_RGBA_TYPE)])
|
|
(and gl
|
|
(send bm install-gl-context
|
|
(new gl-context%
|
|
[gl gl]
|
|
[drawable glpx]))))))))))
|