diff --git a/pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap.rkt b/pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap.rkt index d2e5747228..dea6660321 100644 --- a/pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap.rkt +++ b/pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap.rkt @@ -27,7 +27,8 @@ build-cairo-surface quartz-bitmap% win32-no-hwnd-bitmap% - install-bitmap-dc-class!)) + install-bitmap-dc-class! + surface-flush)) (define -bitmap-dc% #f) (define (install-bitmap-dc-class! v) (set! -bitmap-dc% v)) @@ -39,7 +40,8 @@ (define-local-member-name get-alphas-as-mask - set-alphas-as-mask) + set-alphas-as-mask + surface-flush) (define (bitmap-file-kind-symbol? s) (memq s '(unknown unknown/mask unknown/alpha @@ -171,6 +173,9 @@ (init-rest args) (super-new) + (define/public (surface-flush) + (cairo_surface_flush s)) + (define-values (alt? width height b&w? alpha-channel? s loaded-mask backing-scale) (case-args args @@ -594,7 +599,7 @@ ;; Write a 1-bit png (let* ([b (ceiling (/ width 8))] [rows (build-vector height (lambda (i) (make-bytes b)))] - [data (begin (cairo_surface_flush s) + [data (begin (surface-flush) (cairo_image_surface_get_data s))] [row-width (cairo_image_surface_get_stride s)]) (for ([j (in-range height)]) @@ -736,7 +741,7 @@ ;; Get pixels: (when (not get-alpha?) (let-values ([(A R G B) (argb-indices)]) - (cairo_surface_flush s) + (surface-flush) (let ([data (cairo_image_surface_get_data s)] [row-width (cairo_image_surface_get_stride s)] [um (and (or (and alpha-channel? (not pre-mult?)) b&w?) @@ -815,7 +820,7 @@ [(width) (if unscaled? (*i width backing-scale) width)] [(height) (if unscaled? (*i height backing-scale) height)]) (when (not set-alpha?) - (cairo_surface_flush s) + (surface-flush) (let ([data (cairo_image_surface_get_data s)] [row-width (cairo_image_surface_get_stride s)] [m (and (not pre-mult?) (get-mult-table))]) @@ -881,7 +886,7 @@ (define/public (get-alphas-as-mask x y w h bstr width height) (let ([data (cairo_image_surface_get_data (if (or b&w? alpha-channel?) (begin - (cairo_surface_flush s) + (surface-flush) s) (begin (prep-alpha width height) @@ -903,7 +908,7 @@ (unless alpha-s (set! alpha-s (cairo_image_surface_create CAIRO_FORMAT_ARGB32 width height))) - (cairo_surface_flush s) + (surface-flush) (cairo_surface_flush alpha-s) (let ([data (cairo_image_surface_get_data s)] [alpha-data (cairo_image_surface_get_data alpha-s)] @@ -939,7 +944,7 @@ [row-width (cairo_image_surface_get_stride s)] [A (a-index)] [B (b-index)]) - (cairo_surface_flush s) + (surface-flush) (for ([j (in-range y (min (+ y h) height))]) (let ([row (* j row-width)] [src-row (* (- j y) src-w)]) diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/agl.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/agl.rkt deleted file mode 100644 index 3a7fea351e..0000000000 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/agl.rkt +++ /dev/null @@ -1,155 +0,0 @@ -#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 (get-handle) - 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* ([share-context (send conf get-share-context)] - [context-handle (if share-context (send share-context get-handle) #f)] - [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 context-handle)] - [d-agl (or dummy-agl - (let ([d (aglCreateContext fmt context-handle)]) - (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))))))))) - diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/cgl.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/cgl.rkt new file mode 100644 index 0000000000..e30806e8fc --- /dev/null +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/cgl.rkt @@ -0,0 +1,289 @@ +#lang racket/base +(require racket/class + ffi/unsafe + ffi/unsafe/define + ffi/unsafe/alloc + "../../lock.rkt" + "utils.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 cgl-lib + (ffi-lib "/System/Library/Frameworks/OpenGL.framework/OpenGL")) + +(define-ffi-definer define-cgl cgl-lib) + +(define _GLsizei _int) +(define _GLenum _int) +(define _GLboolean _bool) +(define _GLint _int) +(define _GLuint _uint) +(define _CGLPixelFormatAttribute _int) +(define _CGLError _int) +(define _CGLPixelFormatObj (_cpointer/null 'CGLPixelFormatObj)) +(define _CGLContextObj (_cpointer/null 'CGLContextObj)) + +(define (check-ok who r) + (unless (zero? r) + (error who "failed\n error code: ~e" r))) + +(define-cgl CGLChoosePixelFormat (_fun (_list i _CGLPixelFormatAttribute) + (fmt : (_ptr o _CGLPixelFormatObj)) + (n : (_ptr o _GLint)) + -> (r : _CGLError) + -> (and (zero? r) fmt))) +(define-cgl CGLDestroyPixelFormat (_fun _CGLPixelFormatObj + -> (r : _CGLError) + -> (check-ok 'CGLDestroyPixelFormat r))) + +(define-cgl CGLDestroyContext (_fun _CGLContextObj + -> (r : _CGLError) + -> (check-ok 'CGLDestroyContext r)) + #:wrap (deallocator)) +(define-cgl CGLCreateContext (_fun _CGLPixelFormatObj + _CGLContextObj + (ctx : (_ptr o _CGLContextObj)) + -> (r : _CGLError) + -> (and (zero? r) ctx)) + #:wrap (allocator CGLDestroyContext)) + +(define-cgl CGLSetOffScreen (_fun _CGLContextObj _GLsizei _GLsizei _GLsizei _pointer + -> (r : _CGLError) + -> (check-ok 'CGLSetOffScreen r))) + +(define-cgl CGLSetCurrentContext (_fun _CGLContextObj + -> (r : _CGLError) + -> (check-ok 'CGLSetCurrentContext r))) + +(define-cgl glGenFramebuffersEXT (_fun _GLint (fb : (_ptr o _GLuint)) + -> _void + -> fb)) +(define-cgl glBindFramebufferEXT (_fun _GLenum _GLuint + -> _void)) + +(define-cgl glGenRenderbuffersEXT (_fun _GLsizei (txt : (_ptr o _GLuint)) + -> _void + -> txt)) +(define-cgl glBindRenderbufferEXT (_fun _GLenum _GLuint + -> _void)) +(define-cgl glRenderbufferStorageEXT (_fun _GLenum _GLenum _GLsizei _GLsizei + -> _void)) +(define-cgl glFramebufferRenderbufferEXT (_fun _GLenum _GLenum _GLenum _GLuint + -> _void)) +(define-cgl glReadPixels (_fun _GLint _GLint _GLsizei _GLsizei _GLenum _GLenum _pointer + -> _void)) + +(define GL_FRAMEBUFFER_EXT #x8D40) +(define GL_TEXTURE_2D #x0DE1) +(define GL_RENDERBUFFER_EXT #x8D41) +(define GL_RGBA #x1908) +(define GL_RGBA8 #x8058) +(define GL_DEPTH_COMPONENT16 #x81A5) +(define GL_UNSIGNED_BYTE #x1401) +(define GL_COLOR_ATTACHMENT0_EXT #x8CE0) +(define GL_DEPTH_ATTACHMENT_EXT #x8D00) + +(define kCGLPFAAllRenderers 1) +(define kCGLPFADoubleBuffer 5) +(define kCGLPFAStereo 6) +(define kCGLPFAAuxBuffers 7) +(define kCGLPFAColorSize 8) +(define kCGLPFAAlphaSize 11) +(define kCGLPFADepthSize 12) +(define kCGLPFAStencilSize 13) +(define kCGLPFAAccumSize 14) +(define kCGLPFAMinimumPolicy 51) +(define kCGLPFAMaximumPolicy 52) +(define kCGLPFAOffScreen 53) +(define kCGLPFAFullScreen 54) +(define kCGLPFASampleBuffers 55) +(define kCGLPFASamples 56) +(define kCGLPFAAuxDepthStencil 57) +(define kCGLPFAColorFloat 58) +(define kCGLPFAMultisample 59) +(define kCGLPFASupersample 60) +(define kCGLPFASampleAlpha 61) +(define kCGLPFARendererID 70) +(define kCGLPFASingleRenderer 71) +(define kCGLPFANoRecovery 72) +(define kCGLPFAAccelerated 73) +(define kCGLPFAClosestPolicy 74) +(define kCGLPFARobust 75) +(define kCGLPFABackingStore 76) +(define kCGLPFAMPSafe 78) +(define kCGLPFAWindow 80) +(define kCGLPFAMultiScreen 81) +(define kCGLPFACompliant 83) +(define kCGLPFADisplayMask 84) +(define kCGLPFAPBuffer 90) +(define kCGLPFARemotePBuffer 91) +(define kCGLPFAAllowOfflineRenderers 96) +(define kCGLPFAAcceleratedCompute 97) +(define kCGLPFAOpenGLProfile 99) +(define kCGLPFAVirtualScreenCount 128) + +(define dummy-cgl #f) +(define current-cgl #f) + +(define cgl-context% + (let ([orig-gl-context% gl-context%]) + (define gl-context% + (class orig-gl-context% + (init-field cgl touched) + + (define/override (get-handle) + cgl) + + (define/override (do-call-as-current t) + (dynamic-wind + (lambda () + (set-box! touched #t) + (atomically + (CGLSetCurrentContext cgl) + (set! current-cgl cgl))) + t + (lambda () + (atomically + (CGLSetCurrentContext dummy-cgl) + (set! current-cgl #f))))) + + (define/override (do-swap-buffers) + (void)) + + (super-new))) + gl-context%)) + + +(define cgl-bitmap% + (let ([orig-bitmap% bitmap%]) + (define bitmap% + (class orig-bitmap% + (init _cgl w h) + (super-make-object w h) + + (define cgl _cgl) + (define width w) + (define height h) + + (define bstr (make-bytes (* w h 4))) + (define row-bstr (make-bytes (* w w))) + + (define touched (box #f)) + + (define ctx (make-object cgl-context% cgl touched)) + + (define/override (get-bitmap-gl-context) + ctx) + + (define/override (get-cairo-surface) + (surface-flush) + (super get-cairo-surface)) + + (define/override (surface-flush) + (when (version-10.7-or-later?) + (define s (super get-cairo-surface)) + (atomically + (CGLSetCurrentContext cgl) + (glReadPixels 0 0 width height GL_RGBA GL_UNSIGNED_BYTE bstr) + (CGLSetCurrentContext (or current-cgl dummy-cgl))) + (cond + [(system-big-endian?) + ;; need ARGB + (for ([i (in-range 0 (* width height 4) 4)]) + (define a (bytes-ref bstr (+ i 3))) + (bytes-set! bstr (+ i 1) (bytes-ref bstr i)) + (bytes-set! bstr (+ i 2) (bytes-ref bstr (+ i 1))) + (bytes-set! bstr (+ i 3) (bytes-ref bstr (+ i 2))) + (bytes-set! bstr i a))] + [else + ;; need GBRA + (for ([i (in-range 0 (* width height 4) 4)]) + (define g (bytes-ref bstr i)) + (bytes-set! bstr i (bytes-ref bstr (+ i 2))) + (bytes-set! bstr (+ i 2) g))]) + ;; flip upside-down + (for ([i (in-range (quotient height 2))]) + (define above-row (ptr-add bstr (* 4 i width))) + (define below-row (ptr-add bstr (* 4 (- height i) width))) + (memcpy row-bstr above-row (* 4 width)) + (memcpy above-row below-row (* 4 width)) + (memcpy below-row row-bstr (* 4 width))) + ;; assuming that stride = width + (memcpy (cairo_image_surface_get_data s) bstr (* width height 4))) + (super surface-flush)) + + (define/override (release-bitmap-storage) + (set! ctx #f) + (super release-bitmap-storage)))) + bitmap%)) + +(define (create-gl-bitmap w h conf) + (let* ([share-context (send conf get-share-context)] + [context-handle (if share-context (send share-context get-handle) #f)] + [fmt (CGLChoosePixelFormat + (append + (list kCGLPFASampleAlpha + kCGLPFAColorSize 32) + (if (version-10.7-or-later?) + null ; must use framebuffers + (list kCGLPFAOffScreen)) + (if (send conf get-stereo) (list kCGLPFAStereo) null) + (list + kCGLPFADepthSize (send conf get-depth-size) + kCGLPFAStencilSize (send conf get-stencil-size)) + (let ([as (send conf get-accum-size)]) + (if (or (version-10.7-or-later?) ; deprecated in 10.7 and later + (zero? as)) + null + (list kCGLPFAAccumSize as))) + (let ([ms (send conf get-multisample-size)]) + (if (zero? ms) + null + (list kCGLPFASampleBuffers 1 + kCGLPFASamples ms))) + (list 0)))]) + (and fmt + (let ([cgl (CGLCreateContext fmt context-handle)] + [d-cgl (or dummy-cgl + (let ([d (CGLCreateContext fmt #f)]) + (when d + (set! dummy-cgl d) + d)))]) + (and cgl + d-cgl + (let ([bm (make-object cgl-bitmap% cgl w h #f #t)]) + (and (send bm ok?) + (let ([s (send bm get-cairo-surface)]) + (and (cond + [(version-10.7-or-later?) + (atomically + (CGLSetCurrentContext cgl) + + (define fb (glGenFramebuffersEXT 1)) + (glBindFramebufferEXT GL_FRAMEBUFFER_EXT fb) + + (define rb (glGenRenderbuffersEXT 1)) + (glBindRenderbufferEXT GL_RENDERBUFFER_EXT rb) + (glRenderbufferStorageEXT GL_RENDERBUFFER_EXT GL_RGBA8 w h) + (glFramebufferRenderbufferEXT GL_FRAMEBUFFER_EXT GL_COLOR_ATTACHMENT0_EXT + GL_RENDERBUFFER_EXT rb) + + (unless (zero? (send conf get-depth-size)) + (define rb2 (glGenRenderbuffersEXT 1)) + (glBindRenderbufferEXT GL_RENDERBUFFER_EXT rb2) + (glRenderbufferStorageEXT GL_RENDERBUFFER_EXT GL_DEPTH_COMPONENT16 w h) + (glFramebufferRenderbufferEXT GL_FRAMEBUFFER_EXT GL_DEPTH_ATTACHMENT_EXT + GL_RENDERBUFFER_EXT rb2)) + + (CGLSetCurrentContext (or current-cgl dummy-cgl)))] + [else + (CGLSetOffScreen cgl w h + (cairo_image_surface_get_stride s) + (cairo_image_surface_get_data s))]) + bm))))))))) + diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/procs.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/procs.rkt index d5edd7491f..c0f9f1b6f8 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/procs.rkt +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/procs.rkt @@ -16,7 +16,7 @@ "dc.rkt" "printer-dc.rkt" "menu-bar.rkt" - "agl.rkt" + "cgl.rkt" "sound.rkt" "keycode.rkt" "../../lock.rkt" diff --git a/pkgs/sgl/examples/gears-bitmap.rkt b/pkgs/sgl/examples/gears-bitmap.rkt new file mode 100644 index 0000000000..3a9ba2841a --- /dev/null +++ b/pkgs/sgl/examples/gears-bitmap.rkt @@ -0,0 +1,25 @@ +#lang racket/base +(require racket/draw + racket/gui/base + racket/class + "gears.rkt") + +(define w 400) +(define h 400) + +(define bm (make-gl-bitmap w h (new gl-config%))) +(define gears (new gears% + [with-gl-context + (lambda (thunk) + (send (send (send bm make-dc) get-gl-context) + call-as-current + thunk))] + [swap-gl-buffers void] + [refresh void] + [verbose? #f])) +(send gears set-size w h) +(void (send gears draw)) + +(define dest (build-path (find-system-path 'temp-dir) "gears.png")) +(when (send bm save-file dest 'png) + (printf "wrote to ~a\n" dest)) diff --git a/pkgs/sgl/examples/gears.rkt b/pkgs/sgl/examples/gears.rkt index 70196b3ed9..be41e10f2d 100644 --- a/pkgs/sgl/examples/gears.rkt +++ b/pkgs/sgl/examples/gears.rkt @@ -1,3 +1,4 @@ +#lang racket/base ;; $Id: gears.rkt,v 1.8 2005/01/12 12:49:10 mflatt Exp $ ;; ;; This is a version of the venerable "gears" demo for PLT Scheme 200 using @@ -31,22 +32,24 @@ ;; ;; Updated to newer sgl interface by Scott Owens - -(module gears mzscheme -(require mred - mzlib/class - mzlib/math +(require racket/draw + racket/class + racket/math sgl sgl/gl-vectors) +(provide gears%) (define controls? #t) -(define gears-canvas% - (class* canvas% () +(define gears% + (class object% + (init-field with-gl-context + swap-gl-buffers + refresh + verbose?) - (inherit refresh with-gl-context swap-gl-buffers get-parent - get-top-level-window) + (super-new) (define rotation 0.0) @@ -60,6 +63,9 @@ (define step? #f) + (define/public (ready?) + (and gear1 #t)) + (define/public (run) (set! step? #t) (refresh)) @@ -232,25 +238,16 @@ (gl-vertex (* r0 cos-angle) (* r0 sin-angle) half-width))) (gl-end))) - (define/private (report-no-gl) - (message-box "Gears" - (string-append - "There was an error initializing OpenGL. " - "Maybe OpenGL is not supported on the current platform.") - (get-top-level-window) - '(ok stop)) - (exit 1)) - - (define/override (on-size width height) + (define/public (set-size width height) (with-gl-context - #:fail (lambda () (report-no-gl)) (lambda () - (unless gear1 - (printf " RENDERER: ~A\n" (gl-get-string 'renderer)) - (printf " VERSION: ~A\n" (gl-get-string 'version)) - (printf " VENDOR: ~A\n" (gl-get-string 'vendor)) - (printf " EXTENSIONS: ~A\n" (gl-get-string 'extensions))) + (when verbose? + (unless gear1 + (printf " RENDERER: ~A\n" (gl-get-string 'renderer)) + (printf " VERSION: ~A\n" (gl-get-string 'version)) + (printf " VENDOR: ~A\n" (gl-get-string 'vendor)) + (printf " EXTENSIONS: ~A\n" (gl-get-string 'extensions)))) (gl-viewport 0 0 width height) (gl-matrix-mode 'projection) @@ -296,23 +293,13 @@ (gl-enable 'normalize)))) (refresh)) - - (define sec (current-seconds)) - (define frames 0) - (define/override (on-paint) + (define/public (draw) (when gear1 - (when (>= (- (current-seconds) sec) 5) - (send (get-parent) set-status-text (format "~a fps" (/ (exact->inexact frames) 5))) - (set! sec (current-seconds)) - (set! frames 0)) - (set! frames (add1 frames)) - (when step? ;; TODO: Don't increment this infinitely. (set! rotation (+ 2.0 rotation))) (with-gl-context - #:fail (lambda () (report-no-gl)) (lambda () (gl-clear-color 0.0 0.0 0.0 0.0) @@ -344,35 +331,83 @@ (gl-pop-matrix) (swap-gl-buffers) - (gl-flush))) - (when step? - (set! step? #f) - (queue-callback (lambda x (send this run)) #f)))) + (gl-flush)))) + (cond + [step? + (set! step? #f) + #t] + [else #f])))) - (super-instantiate () (style '(gl no-autoclear))))) -(define (f) - (let* ((f (make-object frame% "gears.rkt" #f)) - (c (instantiate gears-canvas% (f) (min-width 300) (min-height 300)))) +(module+ main + (require racket/gui/base) + + (define gears-canvas% + (class* canvas% () + (inherit refresh with-gl-context swap-gl-buffers get-parent + get-top-level-window) + + (define gears (new gears% + [with-gl-context + (lambda (thunk) + (with-gl-context + #:fail (lambda () (report-no-gl)) + thunk))] + [swap-gl-buffers + (lambda () (swap-gl-buffers))] + [refresh + (lambda () (refresh))] + [verbose? #t])) + + (define/public (get-gears) gears) + + (super-new [style '(gl no-autoclear)]) + + (define/private (report-no-gl) + (message-box "Gears" + (string-append + "There was an error initializing OpenGL. " + "Maybe OpenGL is not supported on the current platform.") + (get-top-level-window) + '(ok stop)) + (exit 1)) + + (define/override (on-size width height) + (send gears set-size width height)) + + (define sec (current-seconds)) + (define frames 0) + + (define/override (on-paint) + (when (send gears ready?) + (when (>= (- (current-seconds) sec) 5) + (send (get-parent) set-status-text (format "~a fps" (/ (exact->inexact frames) 5))) + (set! sec (current-seconds)) + (set! frames 0)) + (set! frames (add1 frames)) + + (when (send gears draw) + (queue-callback (lambda x (send gears run)) #f)))))) + + (let* ((f (new frame% [label "gears.rkt"])) + (c (new gears-canvas% (parent f) (min-width 300) (min-height 300)))) + (define g (send c get-gears)) (send f create-status-line) (when controls? (let ((h (instantiate horizontal-panel% (f) (alignment '(center center)) (stretchable-height #f)))) (instantiate button% - ("Start" h (lambda (b e) (send b enable #f) (send c run))) + ("Start" h (lambda (b e) (send b enable #f) (send g run))) (stretchable-width #t) (stretchable-height #t)) (let ((h (instantiate horizontal-panel% (h) (alignment '(center center))))) - (instantiate button% ("Left" h (lambda x (send c move-left))) + (instantiate button% ("Left" h (lambda x (send g move-left))) (stretchable-width #t)) (let ((v (instantiate vertical-panel% (h) (alignment '(center center)) (stretchable-width #f)))) - (instantiate button% ("Up" v (lambda x (send c move-up))) + (instantiate button% ("Up" v (lambda x (send g move-up))) (stretchable-width #t)) - (instantiate button% ("Down" v (lambda x (send c move-down))) + (instantiate button% ("Down" v (lambda x (send g move-down))) (stretchable-width #t))) - (instantiate button% ("Right" h (lambda x (send c move-right))) + (instantiate button% ("Right" h (lambda x (send g move-right))) (stretchable-width #t))))) (send f show #t))) - (f) -) -;;eof