From 1944cd8dbde645f06c051d5c0696a8e4d2bdb849 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 18 Dec 2015 15:57:42 -0700 Subject: [PATCH] regsiter-collecting-blit: support background bitmap in El Capitan The GC blit implementation used on Mc OS X 10.11 assumed that the no-GC bitmap is blank. Make it use the given no-GC bitmap. Also, repair the left-to-right flipping(!) of the GC bitmap, and repair a backing-scale mismatch that could leave a thin border around a GC blit. --- gui-lib/mred/private/wx/cocoa/canvas.rkt | 71 ++++++++++++++++-------- gui-lib/mred/private/wx/cocoa/gc.rkt | 37 +++++++++--- 2 files changed, 79 insertions(+), 29 deletions(-) diff --git a/gui-lib/mred/private/wx/cocoa/canvas.rkt b/gui-lib/mred/private/wx/cocoa/canvas.rkt index a3a56d6f..87416211 100644 --- a/gui-lib/mred/private/wx/cocoa/canvas.rkt +++ b/gui-lib/mred/private/wx/cocoa/canvas.rkt @@ -99,7 +99,13 @@ (define-objc-class RacketGCGLView NSOpenGLView #:mixins (KeyMouseResponder) - [wxb]) + [wxb] + (-a #:async-apply (box (void)) + _void (drawRect: [_NSRect r]) + (when wxb + (let ([wx (->wx wxb)]) + (when wx + (send wx draw-gc-background)))))) (define-objc-class RacketGCWindow NSWindow #:mixins (RacketEventspaceMethods) @@ -920,9 +926,9 @@ (define/private (suspend-all-reg-blits) (let ([cocoa-win (get-cocoa-window)]) (for ([r (in-list reg-blits)]) - (tellv cocoa-win removeChildWindow: (car r)) - (release (car r)) - (scheme_remove_gc_callback (cdr r)))) + (tellv cocoa-win removeChildWindow: (vector-ref r 0)) + (release (vector-ref r 0)) + (scheme_remove_gc_callback (vector-ref r 1)))) (set! reg-blits null)) (define/public (resume-all-reg-blits) @@ -930,10 +936,10 @@ (when (pair? blits) (set! reg-blits (for/list ([b (in-list blits)]) - (let-values ([(x y w h s img) (apply values b)]) - (register-one-blit x y w h s img))))))) + (let-values ([(x y w h s img us unimg) (apply values b)]) + (register-one-blit x y w h s img us unimg))))))) - (define/private (register-one-blit x y w h s img) + (define/private (register-one-blit x y w h s img us unimg) (let ([xb (box x)] [yb (box y)]) (client-to-screen xb yb #f) @@ -963,7 +969,8 @@ (tellv win setAcceptsMouseMovedEvents: #:type _BOOL #t) (set-ivar! win wxb (->wxb this)) (set-ivar! glv wxb (->wxb this)) - (tellv glv setWantsBestResolutionOpenGLSurface: #:type _uint 1) + (unless (= s 1) + (tellv glv setWantsBestResolutionOpenGLSurface: #:type _uint 1)) (tellv (tell win contentView) addSubview: glv)] [else (tellv win setAlphaValue: #:type _CGFloat 0.0) @@ -976,36 +983,56 @@ (when gc-via-gl? (tellv win orderWindow: #:type _int NSWindowAbove relativeTo: #:type _NSInteger (tell #:type _NSInteger cocoa-win windowNumber))) + (define uninstall-desc + (if gc-via-gl? + (if (and unimg + ;; all white? + (not (for/and ([i (in-range 0 (bytes-length unimg) 4)]) + (or (= (bytes-ref unimg i) 0) + (and (= (bytes-ref unimg (+ 1 i)) 255) + (= (bytes-ref unimg (+ 2 i)) 255) + (= (bytes-ref unimg (+ 3 i)) 255)))))) + (make-gl-install win glv w h unimg us) + (make-gl-uninstall win glv w h)) + (make-gc-action-desc win (selector setAlphaValue:) 0.0))) (let ([r (scheme_add_gc_callback (if gc-via-gl? (make-gl-install win glv w h img s) (make-gc-action-desc win (selector setAlphaValue:) 1.0)) - (if gc-via-gl? - (make-gl-uninstall win glv w h) - (make-gc-action-desc win (selector setAlphaValue:) 0.0)))]) + uninstall-desc)]) (when gc-via-gl? (tellv glv release)) - (cons win r))))))) + (vector win r uninstall-desc))))))) (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) (let ([on (fix-bitmap-size on w h on-x on-y)] - [s (send on get-backing-scale)]) + [off (and gc-via-gl? + (fix-bitmap-size off w h on-x on-y))] + [s (send on get-backing-scale)] + [us (send off get-backing-scale)]) + (define (bm->img on s) + (let* ([xw (inexact->exact (ceiling (* s w)))] + [xh (inexact->exact (ceiling (* s h)))] + [rgba (make-bytes (* xw xh 4))]) + (send on get-argb-pixels 0 0 xw xh rgba #:unscaled? #t) + rgba)) (let ([img (if gc-via-gl? - (let* ([xw (inexact->exact (ceiling (* s w)))] - [xh (inexact->exact (ceiling (* s h)))] - [rgba (make-bytes (* xw xh 4))]) - (send on get-argb-pixels 0 0 xw xh rgba #:unscaled? #t) - rgba) - (bitmap->image on))]) + (bm->img on s) + (bitmap->image on))] + [unimg (and gc-via-gl? (bm->img off us))]) (atomically - (set! blits (cons (list x y w h s img) blits)) + (set! blits (cons (list x y w h s img us unimg) blits)) (when (is-shown-to-root?) - (set! reg-blits (cons (register-one-blit x y w h s img) reg-blits))))))) + (set! reg-blits (cons (register-one-blit x y w h s img us unimg) reg-blits))))))) (define/public (unregister-collecting-blits) (atomically (suspend-all-reg-blits) - (set! blits null)))))) + (set! blits null))) + + (define/public (draw-gc-background) + (for ([rb (in-list reg-blits)]) + (do-gl-action (vector-ref rb 2))))))) (define canvas-panel% (class (panel-mixin canvas%) diff --git a/gui-lib/mred/private/wx/cocoa/gc.rkt b/gui-lib/mred/private/wx/cocoa/gc.rkt index d88842be..e619f037 100644 --- a/gui-lib/mred/private/wx/cocoa/gc.rkt +++ b/gui-lib/mred/private/wx/cocoa/gc.rkt @@ -10,7 +10,8 @@ scheme_remove_gc_callback make-gc-action-desc make-gl-install - make-gl-uninstall)) + make-gl-uninstall + do-gl-action)) ;; ---------------------------------------- ;; 10.10 and earlier: change window opacity @@ -74,6 +75,9 @@ (define-gl glClearColor (_fun _GLclampf _GLclampf _GLclampf _GLclampf -> _void)) (define-gl glClear (_fun _GLbitfield -> _void)) +(define-gl glCallList (_fun _GLint -> _void)) +(define-gl glFlush (_fun -> _void)) + (define-gl glClear-pointer _fpointer #:c-id glClear) (define-gl glCallList-pointer _fpointer @@ -112,12 +116,14 @@ (define size (* w h 4)) (define size-4 (- size 4)) (define rgba (make-bytes size)) - (for ([i (in-range 0 size 4)]) - (define j (- size-4 i)) - (bytes-set! rgba (+ i 3) (bytes-ref argb j)) - (bytes-set! rgba i (bytes-ref argb (+ j 1))) - (bytes-set! rgba (+ i 1) (bytes-ref argb (+ j 2))) - (bytes-set! rgba (+ i 2) (bytes-ref argb (+ j 3)))) + (for ([x (in-range w)]) + (for ([y (in-range h)]) + (define i (* (+ x (* w y)) 4)) + (define j (* (+ x (* w (- h y 1))) 4)) + (bytes-set! rgba (+ i 3) (bytes-ref argb j)) + (bytes-set! rgba i (bytes-ref argb (+ j 1))) + (bytes-set! rgba (+ i 1) (bytes-ref argb (+ j 2))) + (bytes-set! rgba (+ i 2) (bytes-ref argb (+ j 3))))) (define tex (glGenTexture)) @@ -172,6 +178,8 @@ (tellv old-gl makeCurrentContext) (tellv NSOpenGLContext clearCurrentContext)) + ;; The shape of this vector is parsed back out by + ;; `do-gl-action`, below: (vector (vector 'ptr_ptr->save msg-send-proc @@ -237,3 +245,18 @@ (vector 'save!_ptr->void msg-send-proc (selector makeCurrentContext)))) + +(define (do-gl-action vec) + (when (= 8 (vector-length vec)) + (define gl (vector-ref (vector-ref vec 1) 2)) + (define list-id (vector-ref (vector-ref vec 3) 2)) + + (define old-ctx (tell NSOpenGLContext currentContext)) + (tellv gl makeCurrentContext) + (glClear GL_COLOR_BUFFER_BIT) + (glCallList list-id) + (glFlush) + (tellv gl flushBuffer) + (tellv NSOpenGLContext clearCurrentContext) + (when old-ctx + (tellv old-ctx makeCurrentContext))))