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

regsiter-collecting-blit: support background bitmap in El Capitan

Browse Source 
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.
This commit is contained in:
Matthew Flatt 2015-12-18 15:57:42 -07:00
parent 7c43e6d876
commit 1944cd8dbd
2 changed files with 79 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
gui-lib/mred/private/wx/cocoa/canvas.rkt
View File

@ -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%)

37
gui-lib/mred/private/wx/cocoa/gc.rkt
View File

@ -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))))