suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

`make-gl-bitmap' for cocoa and maybe gtk

Browse Source
This commit is contained in:
Matthew Flatt 2010-10-13 20:49:27 -06:00
parent bc509c86cd
commit 0a47a81aba
20 changed files with 281 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/mred/mred-sig.rkt
View File

@ -123,6 +123,7 @@ make-eventspace
make-gui-empty-namespace
make-gui-namespace
make-screen-bitmap
make-gl-bitmap
map-command-as-meta-key
menu%
menu-bar%

3
collects/mred/mred.rkt
View File

@ -191,7 +191,8 @@
the-brush-list
the-style-list
the-editor-wordbreak-map
make-screen-bitmap)
make-screen-bitmap
make-gl-bitmap)
(define the-clipboard (wx:get-the-clipboard))
(define the-x-selection-clipboard (wx:get-the-x-selection))

150
collects/mred/private/wx/cocoa/agl.rkt Normal file
View File

@ -0,0 +1,150 @@
#lang racket/base
(require racket/class
ffi/unsafe
ffi/unsafe/define
ffi/unsafe/alloc
"../../lock.rkt"
racket/draw/cairo
racket/draw/local
racket/draw/gl-context
racket/draw/gl-config
racket/draw/bitmap)
(provide 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)))))))))

3
collects/mred/private/wx/cocoa/canvas.rkt
View File

@ -206,12 +206,11 @@
NSOpenGLPFADepthSize (send conf get-depth-size)
NSOpenGLPFAStencilSize (send conf get-stencil-size)
NSOpenGLPFAAccumSize (send conf get-accum-size))
#;
(let ([ms (send conf get-multisample-size)])
(if (zero? ms)
null
(list NSOpenGLPFAMultisample
NSOpenGLPFASampleBuffers
NSOpenGLPFASampleBuffers 1
NSOpenGLPFASamples ms)))
(list 0)))))

1
collects/mred/private/wx/cocoa/platform.rkt
View File

@ -85,4 +85,5 @@
get-highlight-background-color
get-highlight-text-color
make-screen-bitmap
make-gl-bitmap
check-for-break))

7
collects/mred/private/wx/cocoa/procs.rkt
View File

@ -12,6 +12,7 @@
"filedialog.rkt"
"dc.rkt"
"menu-bar.rkt"
"agl.rkt"
"../../lock.rkt"
"../common/handlers.rkt")
@ -52,6 +53,7 @@
get-highlight-background-color
get-highlight-text-color
make-screen-bitmap
make-gl-bitmap
check-for-break)
(import-class NSScreen NSCursor)
@ -113,6 +115,11 @@
[exact-positive-integer? h])
(make-object quartz-bitmap% w h))
(define/top (make-gl-bitmap [exact-positive-integer? w]
[exact-positive-integer? h]
[gl-config% c])
(create-gl-bitmap w h c))
;; ------------------------------------------------------------
;; Text & highlight color

8
collects/mred/private/wx/gtk/dc.rkt
View File

@ -37,6 +37,14 @@
w
h))
;; `get-gdk-pixmap' and `install-gl-context' are
;; localized in "gl-context.rkt"
(define/public (get-gdk-pixmap) pixmap)
(define/public (install-gl-context new-gl) (set! gl new-gl))
(define gl #f)
(define/override (get-bitmap-gl-context) gl)
(define/override (ok?) #t)
(define/override (is-color?) #t)
(define/override (has-alpha-channel?) #f)

50
collects/mred/private/wx/gtk/gl-context.rkt
View File

@ -2,13 +2,18 @@
(require racket/class
ffi/unsafe
ffi/unsafe/define
ffi/unsafe/alloc
(prefix-in draw: racket/draw/gl-context)
racket/draw/gl-config
"types.rkt"
"utils.rkt")
(provide prepare-widget-gl-context
create-widget-gl-context)
create-widget-gl-context
create-and-install-gl-context
get-gdk-pixmap
install-gl-context)
(define gdkglext-lib
(ffi-lib "libgdkglext-x11-1.0" '("0")))
@ -23,6 +28,8 @@
(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)
@ -45,12 +52,26 @@
(define-gtkglext gtk_widget_get_gl_context (_fun _GtkWidget -> _GdkGLContext))
(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_gl_pixmap_destroy (_fun _GdkGLPixmap -> _void)
#:wrap (deallocator))
(define-gdkglext gdk_gl_pixmap_new (_fun _GdkGLConfig _GdkPixmap _pointer -> _GdkGLPixmap)
#:wrap (allocator gdk_gl_pixmap_destroy))
(define GDK_GL_RGBA_TYPE 0)
(define GDK_GL_USE_GL 1)
(define GDK_GL_BUFFER_SIZE 2)
(define GDK_GL_LEVEL 3)
@ -74,10 +95,12 @@
;; ----------------------------------------
(define (config->GdkGLConfig d conf)
(define (config->GdkGLConfig d conf can-double?)
(gdk_gl_config_new (append
(list GDK_GL_RGBA)
(if (send conf get-double-buffered) (list GDK_GL_DOUBLEBUFFER) null)
(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)
@ -122,7 +145,8 @@
(init!)
(let ([config (config->GdkGLConfig #f ; (gtk_widget_get_screen gtk)
(or config
(new gl-config%)))])
(new gl-config%))
#t)])
(when config
(gtk_widget_set_gl_capability gtk
config
@ -138,3 +162,21 @@
[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_gl_pixmap_new config gdkpx #f)])
(and glpx
(let ([gl (gdk_gl_context_new glpx #f #t GDK_GL_RGBA_TYPE)])
(and gl
(new gl-context%
[gl gl]
[drawable glpx])))))))))

1
collects/mred/private/wx/gtk/platform.rkt
View File

@ -85,4 +85,5 @@
get-highlight-background-color
get-highlight-text-color
make-screen-bitmap
make-gl-bitmap
check-for-break))

9
collects/mred/private/wx/gtk/procs.rkt
View File

@ -11,6 +11,7 @@
"widget.rkt"
"window.rkt"
"dc.rkt"
"gl-context.rkt"
"../common/handlers.rkt")
(provide
@ -50,6 +51,7 @@
get-highlight-background-color
get-highlight-text-color
make-screen-bitmap
make-gl-bitmap
check-for-break)
(define-unimplemented special-control-key)
@ -118,4 +120,11 @@
(make-object x11-bitmap% w h #f)
(make-object bitmap% w h #f #t)))
(define/top (make-gl-bitmap [exact-positive-integer? w]
[exact-positive-integer? h]
[gl-config% c])
(let ([bm (make-object x11-bitmap% w h #f)])
(create-and-install-gl-context bm c)
bm))
(define (check-for-break) #f)

1
collects/mred/private/wx/platform.rkt
View File

@ -70,5 +70,6 @@
get-highlight-background-color
get-highlight-text-color
make-screen-bitmap
make-gl-bitmap
check-for-break)
((dynamic-require platform-lib 'platform-values)))

1
collects/mred/private/wx/win32/platform.rkt
View File

@ -86,4 +86,5 @@
get-highlight-background-color
get-highlight-text-color
make-screen-bitmap
make-gl-bitmap
check-for-break))

6
collects/mred/private/wx/win32/procs.rkt
View File

@ -48,6 +48,7 @@
get-highlight-background-color
get-highlight-text-color
make-screen-bitmap
make-gl-bitmap
check-for-break)
(define-unimplemented special-control-key)
@ -102,4 +103,9 @@
[exact-positive-integer? h])
(make-object win32-bitmap% w h #f))
(define/top (make-gl-bitmap [exact-positive-integer? w]
[exact-positive-integer? h]
[gl-config% c])
(make-object win32-bitmap% w h #f))
(define (check-for-break) #f)

5
collects/racket/draw/bitmap-dc.rkt
View File

@ -83,6 +83,11 @@
(super-new)
(def/override (get-gl-context)
(let ([bm (internal-get-bitmap)])
(and bm
(send bm get-bitmap-gl-context))))
(def/public (set-bitmap [(make-or-false bitmap%) v])
(internal-set-bitmap v))

3
collects/racket/draw/bitmap.rkt
View File

@ -206,6 +206,9 @@
(set! s #f)
(destroy s2))))
(define/public (get-bitmap-gl-context)
#f)
(define/private (check-ok who)
(unless s
(error (method-name 'bitmap% who) "bitmap is not ok")))

1
collects/racket/draw/local.rkt
View File

@ -11,6 +11,7 @@
get-cairo-surface
get-cairo-alpha-surface
release-bitmap-storage
get-bitmap-gl-context
;; bitmap-dc%
internal-get-bitmap

9
collects/scribblings/gui/canvas-class.scrbl
View File

@ -45,10 +45,11 @@ The @scheme[style] argument indicates one or more of the following styles:
@item{@scheme['resize-corner] --- leaves room for a resize control at the canvas's
bottom right when only one scrollbar is visible}
@item{@scheme['gl] --- enables OpenGL drawing to the canvas, and usually
combined with @racket['no-autoclear]; call the @method[dc<%>
get-gl-context] method of the canvas's drawing context as
produced by @method[canvas<%> get-dc]}
@item{@scheme['gl] --- creates a canvas for OpenGL drawing instead of
normal @racket[dc<%>] drawing; call the @method[dc<%>
get-gl-context] method on the result of @method[canvas<%>
get-dc]; this style is usually combined with
@racket['no-autoclear]}
@item{@scheme['no-autoclear] --- prevents automatic erasing of the
canvas before calls to @method[canvas% on-paint]}

21
collects/scribblings/gui/gl-context-intf.scrbl
View File

@ -8,13 +8,18 @@ A @scheme[gl-context<%>] object represents a context for drawing with
@scheme[gl-context<%>] object, call @method[dc<%> get-gl-context] of
the target drawing context.
Only canvas @scheme[dc<%>] and @scheme[bitmap-dc%] objects support
OpenGL (always under Windows and Mac OS X, sometimes under X), and in
the case of a @scheme[bitmap-dc%], the context is usable only when
the target bitmap is non-monochrome. When the target bitmap for a
@scheme[bitmap-dc%] context is changed via @method[bitmap-dc%
set-bitmap], the associated OpenGL context is reset, but the
@scheme[gl-context<%>] keeps its identity. Canvas contexts are double
Only canvas @scheme[dc<%>] and @scheme[bitmap-dc%] objects containing
a bitmap from @racket[make-gl-bitmap] support OpenGL (always under
Windows and Mac OS X, sometimes under X). Normal @racket[dc<%>]
drawing and OpenGL drawing can be mixed in a @scheme[bitmap-dc%], but
a canvas that uses the @racket['gl] style to support OpenGL does not
reliably support normal @racket[dc<%>] drawing; use a bitmap if you
need to mix drawing modes, and use a canvas to maximize OpenGL
performance.
When the target bitmap for a @scheme[bitmap-dc%] context is changed
via @method[bitmap-dc% set-bitmap], the associated
@scheme[gl-context<%>] changes. Canvas contexts are normally double
buffered, and bitmap contexts are single buffered.
The @schememodname[racket/gui/base] library provides no OpenGL
@ -24,7 +29,7 @@ The @schememodname[racket/gui/base] library provides no OpenGL
context, connecting it to windows and bitmaps.
Only one OpenGL context can be active at a time across all threads and
eventspaces. Except under Mac OS X, OpenGL contexts are not protected
eventspaces. OpenGL contexts are not protected
against interference among threads; that is, if a thread selects one
of its OpenGL contexts, then other threads can write into the context
via OpenGL commands. However, if all threads issue OpenGL commands

14
collects/scribblings/gui/miscwin-funcs.scrbl
View File

@ -276,6 +276,20 @@ Strips shortcut ampersands from @racket[label], removes parenthesized
}
@defproc[(make-gl-bitmap [width exact-positive-integer?]
[height exact-positive-integer?]
[config (is-a?/c gl-config%)])
(is-a/c? bitmap%)]{
Creates a bitmap that supports both normal @racket[dc<%>] drawing an
OpenGL drawing through a context returned by @xmethod[dc<%> get-gl-context].
For @racket[dc<%>] drawing, an OpenGL-supporting bitmap draws like a
bitmap frmo @racket[make-screen-bitmap] on some platforms, while it
draws like a bitmap instantiated directly from @racket[bitmap%] on
other platforms.}
@defproc[(make-gui-empty-namespace) namespace?]{
Like @racket[make-base-empty-namespace], but with

11
doc/release-notes/racket/Draw_and_GUI_5_5.txt
View File

@ -1,4 +1,4 @@
Changes to the drawing toolbox:
Changes:
* The drawing portion of the old GUI toolbox is now available as a
separate layer: `racket/draw'. This layer can be used from plain
@ -15,7 +15,7 @@ Changes to the drawing toolbox:
Drawing to a canvas always draws into a bitmap that is kept
offscreen and periodically flushed onto the screen. The new
`suspend-flush' and `resume-fluah' methods of `canvas%' provide
`suspend-flush' and `resume-flush' methods of `canvas%' provide
some control over the timing of the flushes, which in many cases
avoids the need for (additional) double buffering of canvas
content.
@ -85,8 +85,9 @@ Changes to the drawing toolbox:
`get-highlight-text-color', if any.
* OpenGL drawing in a canvas requires supplying 'gl as a style when
creating the `canvas%' instance.
creating the `canvas%' instance. OpenGL and normal dc<%> drawing no
longer mix reliably in a canvas.
Changes to the GUI toolbox:
OpenG drawing to a bitmap requires a bitmap created with
`make-gl-bitmap'.
[Nothing to report, yet.]