diff --git a/gui-lib/mred/private/wx/cocoa/canvas.rkt b/gui-lib/mred/private/wx/cocoa/canvas.rkt index e181473c..80951fb1 100644 --- a/gui-lib/mred/private/wx/cocoa/canvas.rkt +++ b/gui-lib/mred/private/wx/cocoa/canvas.rkt @@ -12,6 +12,7 @@ "const.rkt" "types.rkt" "window.rkt" + "frame.rkt" "dc.rkt" "cg.rkt" "queue.rkt" @@ -41,7 +42,7 @@ (define NSWindowAbove 1) -(define o (current-error-port)) +(define gc-via-gl? (version-10.11-or-later?)) ;; Called when a canvas has no backing store ready (define (clear-background wxb) @@ -97,6 +98,16 @@ #:mixins (RacketViewMixin) [wxb]) +(define-objc-class RacketGCGLView NSOpenGLView + #:mixins (KeyMouseResponder) + [wxb]) + +(define-objc-class RacketGCWindow NSWindow + #:mixins (RacketEventspaceMethods) + [wxb]) + +(install-RacketGCWindow! RacketGCWindow) + (define-objc-class CornerlessFrameView NSView [] (-a #:async-apply (box (void)) @@ -451,6 +462,10 @@ (make-window-bitmap w h (get-cocoa-window))) (define/override (fix-dc [refresh? #t]) + (when (pair? blits) + (atomically + (suspend-all-reg-blits) + (resume-all-reg-blits))) (when (dc . is-a? . dc%) (send dc reset-backing-retained) (send dc set-auto-scroll @@ -914,17 +929,17 @@ (when (pair? blits) (set! reg-blits (for/list ([b (in-list blits)]) - (let-values ([(x y w h img) (apply values b)]) - (register-one-blit x y w h img))))))) + (let-values ([(x y w h s img) (apply values b)]) + (register-one-blit x y w h s img))))))) - (define/private (register-one-blit x y w h img) + (define/private (register-one-blit x y w h s img) (let ([xb (box x)] [yb (box y)]) (client-to-screen xb yb #f) (let* ([cocoa-win (get-cocoa-window)]) (atomically (let ([win (as-objc-allocation - (tell (tell NSWindow alloc) + (tell (tell (if gc-via-gl? RacketGCWindow NSWindow) alloc) initWithContentRect: #:type _NSRect (make-NSRect (make-NSPoint (unbox xb) (- (unbox yb) h)) @@ -932,26 +947,59 @@ styleMask: #:type _int NSBorderlessWindowMask backing: #:type _int NSBackingStoreBuffered defer: #:type _BOOL NO))] - [iv (tell (tell NSImageView alloc) init)]) - (tellv iv setImage: img) - (tellv iv setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) - (make-NSSize w h))) - (tellv (tell win contentView) addSubview: iv) - (tellv win setAlphaValue: #:type _CGFloat 0.0) + [glv (and gc-via-gl? + (let ([pf (gl-config->pixel-format #f)]) + (begin0 + (tell (tell RacketGCGLView alloc) + initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) + (make-NSSize w h)) + pixelFormat: pf) + (tellv pf release))))] + [iv (and (not gc-via-gl?) + (tell (tell NSImageView alloc) init))]) + (cond + [gc-via-gl? + (tellv win setAcceptsMouseMovedEvents: #:type _BOOL #t) + (set-ivar! win wxb (->wxb this)) + (set-ivar! glv wxb (->wxb this)) + (tellv glv setWantsBestResolutionOpenGLSurface: #:type _uint 1) + (tellv (tell win contentView) addSubview: glv)] + [else + (tellv win setAlphaValue: #:type _CGFloat 0.0) + (tellv iv setImage: img) + (tellv iv setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) + (make-NSSize w h))) + (tellv (tell win contentView) addSubview: iv) + (tellv iv release)]) (tellv cocoa-win addChildWindow: win ordered: #:type _int NSWindowAbove) - (tellv iv release) + (when gc-via-gl? + (tellv win orderWindow: #:type _int NSWindowAbove + relativeTo: #:type _NSInteger (tell #:type _NSInteger cocoa-win windowNumber))) (let ([r (scheme_add_gc_callback - (make-gc-action-desc win (selector setAlphaValue:) 1.0) - (make-gc-action-desc win (selector setAlphaValue:) 0.0))]) + (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)))]) + (when gc-via-gl? + (tellv glv release)) (cons win r))))))) (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)]) - (let ([img (bitmap->image on)]) + (let ([on (fix-bitmap-size on w h on-x on-y)] + [s (send on get-backing-scale)]) + (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))]) (atomically - (set! blits (cons (list x y w h img) blits)) + (set! blits (cons (list x y w h s img) blits)) (when (is-shown-to-root?) - (set! reg-blits (cons (register-one-blit x y w h img) reg-blits))))))) + (set! reg-blits (cons (register-one-blit x y w h s img) reg-blits))))))) (define/public (unregister-collecting-blits) (atomically diff --git a/gui-lib/mred/private/wx/cocoa/frame.rkt b/gui-lib/mred/private/wx/cocoa/frame.rkt index b9740483..94dc002e 100644 --- a/gui-lib/mred/private/wx/cocoa/frame.rkt +++ b/gui-lib/mred/private/wx/cocoa/frame.rkt @@ -18,7 +18,10 @@ (provide (protect-out frame% location->window - get-front)) + get-front + + RacketEventspaceMethods + install-RacketGCWindow!)) ;; ---------------------------------------- @@ -56,11 +59,18 @@ (set-screen-changed-callback! send-screen-change-notifications) -(define-objc-mixin (RacketWindowMethods Superclass) +(define RacketGCWindow #f) +(define (install-RacketGCWindow! c) (set! RacketGCWindow c)) + +(define-objc-mixin (RacketEventspaceMethods Superclass) [wxb] [-a _scheme (getEventspace) (let ([wx (->wx wxb)]) - (and wx (send wx get-eventspace)))] + (and wx (send wx get-eventspace)))]) + +(define-objc-mixin (RacketWindowMethods Superclass) + #:mixins (RacketEventspaceMethods) + [wxb] [-a _BOOL (canBecomeKeyWindow) (let ([wx (->wx wxb)]) (and wx @@ -189,7 +199,9 @@ (not (ptr-equal? w (send root-fake-frame get-cocoa))) (is-mouse-or-key?)) (or (objc-is-a? w RacketWindow) - (objc-is-a? w RacketPanel)) + (objc-is-a? w RacketPanel) + (and RacketGCWindow + (objc-is-a? w RacketGCWindow))) (tell #:type _scheme w getEventspace))] [front (send front get-eventspace)] [root-fake-frame diff --git a/gui-lib/mred/private/wx/cocoa/gc.rkt b/gui-lib/mred/private/wx/cocoa/gc.rkt index 8e384f37..d88842be 100644 --- a/gui-lib/mred/private/wx/cocoa/gc.rkt +++ b/gui-lib/mred/private/wx/cocoa/gc.rkt @@ -1,13 +1,19 @@ #lang racket/base (require ffi/unsafe ffi/unsafe/objc + ffi/unsafe/define "utils.rkt" "types.rkt") (provide (protect-out scheme_add_gc_callback scheme_remove_gc_callback - make-gc-action-desc)) + make-gc-action-desc + make-gl-install + make-gl-uninstall)) + +;; ---------------------------------------- +;; 10.10 and earlier: change window opacity (define objc-lib (ffi-lib "libobjc")) @@ -25,3 +31,209 @@ win sel val))) + +;; ---------------------------------------- +;; 10.11 and later: OpenGL texture + +(define gl-lib (ffi-lib "/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL")) +(define-ffi-definer define-gl gl-lib) + +(import-class NSOpenGLContext) + +(define _GLsizei _int) +(define _GLint _int) +(define _GLuint _uint) +(define _GLenum _int) +(define _GLbitfield _int) +(define _GLfloat _float) +(define _GLclampf _float) + +(define-gl glGenTexture (_fun (_GLsizei = 1) (v : (_ptr o _GLuint)) -> _void -> v) + #:c-id glGenTextures) +(define-gl glGenLists (_fun _GLsizei -> _GLuint)) +(define-gl glNewList (_fun _GLuint _GLenum -> _void)) +(define-gl glEndList (_fun -> _void)) + +(define-gl glBindTexture (_fun _GLenum _GLuint -> _void)) +(define-gl glTexParameteri (_fun _GLenum _GLenum _GLint -> _void)) +(define-gl glTexImage2D (_fun _GLenum _GLint _GLint _GLsizei _GLsizei _GLint _GLenum _GLenum _pointer -> _void)) + +(define-gl glBegin (_fun _GLenum -> _void)) +(define-gl glEnd (_fun -> _void)) +(define-gl glEnable (_fun _GLenum -> _void)) +(define-gl glDisable (_fun _GLenum -> _void)) + +(define-gl glMaterialfv (_fun _GLenum _GLenum (_vector i _GLfloat) -> _void)) +(define-gl glTexCoord2f (_fun _GLfloat _GLfloat -> _void)) +(define-gl glVertex3f (_fun _GLfloat _GLfloat _GLfloat -> _void)) + +(define-gl glViewport (_fun _GLint _GLint _GLsizei _GLsizei -> _void)) +(define-gl glMatrixMode (_fun _GLenum -> _void)) +(define-gl glLoadIdentity (_fun -> _void)) +(define-gl glOrtho (_fun _double _double _double _double _double _double -> _void)) +(define-gl glClearColor (_fun _GLclampf _GLclampf _GLclampf _GLclampf -> _void)) +(define-gl glClear (_fun _GLbitfield -> _void)) + +(define-gl glClear-pointer _fpointer + #:c-id glClear) +(define-gl glCallList-pointer _fpointer + #:c-id glCallList) +(define-gl glFlush-pointer _fpointer + #:c-id glFlush) + +(define GL_TEXTURE_2D #x0DE1) +(define GL_TEXTURE_MAG_FILTER #x2800) +(define GL_TEXTURE_MIN_FILTER #x2801) +(define GL_TEXTURE_WRAP_S #x2802) +(define GL_TEXTURE_WRAP_T #x2803) + +(define GL_LINEAR #x2601) +(define GL_CLAMP #x2900) + +(define GL_RGBA #x1908) + +(define GL_UNSIGNED_BYTE #x1401) + +(define GL_COMPILE #x1300) + +(define GL_FRONT #x0404) +(define GL_AMBIENT_AND_DIFFUSE #x1602) + +(define GL_POLYGON #x0009) + +(define GL_PROJECTION #x1701) +(define GL_MODELVIEW #x1700) + +(define GL_COLOR_BUFFER_BIT #x00004000) + +(define (make-gl-square argb uw uh backing-scale) + (define w (inexact->exact (ceiling (* backing-scale uw)))) + (define h (inexact->exact (ceiling (* backing-scale uh)))) + (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)))) + + (define tex (glGenTexture)) + + (glBindTexture GL_TEXTURE_2D tex) + (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR) + (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR) + (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP) + (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP) + (glTexImage2D GL_TEXTURE_2D 0 GL_RGBA + w h 0 + GL_RGBA GL_UNSIGNED_BYTE rgba) + + (define wi (exact->inexact uw)) + (define hi (exact->inexact uh)) + + (define list-id (glGenLists 1)) + (glNewList list-id GL_COMPILE) + (glEnable GL_TEXTURE_2D) + (glBindTexture GL_TEXTURE_2D tex) + (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE (vector 1.0 1.0 1.0 1.0)) + (glBegin GL_POLYGON) + (glTexCoord2f 0.0 0.0) + (glVertex3f 0.0 0.0 0.0) + (glTexCoord2f 1.0 0.0) + (glVertex3f wi 0.0 0.0) + (glTexCoord2f 1.0 1.0) + (glVertex3f wi hi 0.0) + (glTexCoord2f 0.0 1.0) + (glVertex3f 0.0 hi 0.0) + (glEnd) + (glDisable GL_TEXTURE_2D) + (glEndList) + + list-id) + +(define (make-gl-install win glv w h argb backing-scale) + (define gl (tell glv openGLContext)) + + (define old-gl (tell NSOpenGLContext currentContext)) + (tell gl makeCurrentContext) + (glViewport 0 0 w h) + (glMatrixMode GL_PROJECTION) + (glLoadIdentity) + (glOrtho 0.0 (exact->inexact w) 0.0 (exact->inexact h) -1.0 1.0) + (glMatrixMode GL_MODELVIEW) + (glClearColor 1.0 1.0 1.0 1.0) + (glClear GL_COLOR_BUFFER_BIT) + + (define list-id (make-gl-square argb w h backing-scale)) + + (if old-gl + (tellv old-gl makeCurrentContext) + (tellv NSOpenGLContext clearCurrentContext)) + + (vector + (vector 'ptr_ptr->save + msg-send-proc + NSOpenGLContext + (selector currentContext)) + (vector 'ptr_ptr_ptr->void + msg-send-proc + gl + (selector makeCurrentContext) + #f) + (vector 'int->void + glClear-pointer + GL_COLOR_BUFFER_BIT) + (vector 'int->void + glCallList-pointer + list-id) + (vector 'int->void + glFlush-pointer + 0) + (vector 'ptr_ptr_ptr->void + msg-send-proc + gl + (selector flushBuffer) + #f) + (vector 'ptr_ptr_ptr->void + msg-send-proc + NSOpenGLContext + (selector clearCurrentContext) + #f) + (vector 'save!_ptr->void + msg-send-proc + (selector makeCurrentContext)))) + +(define (make-gl-uninstall win glv w h) + (define gl (tell glv openGLContext)) + + (vector + (vector 'ptr_ptr->save + msg-send-proc + NSOpenGLContext + (selector currentContext)) + (vector 'ptr_ptr_ptr->void + msg-send-proc + gl + (selector makeCurrentContext) + #f) + (vector 'int->void + glClear-pointer + GL_COLOR_BUFFER_BIT) + (vector 'int->void + glFlush-pointer + 0) + (vector 'ptr_ptr_ptr->void + msg-send-proc + gl + (selector flushBuffer) + #f) + (vector 'ptr_ptr_ptr->void + msg-send-proc + NSOpenGLContext + (selector clearCurrentContext) + #f) + (vector 'save!_ptr->void + msg-send-proc + (selector makeCurrentContext)))) diff --git a/gui-lib/mred/private/wx/cocoa/procs.rkt b/gui-lib/mred/private/wx/cocoa/procs.rkt index 5731d013..d0744e74 100644 --- a/gui-lib/mred/private/wx/cocoa/procs.rkt +++ b/gui-lib/mred/private/wx/cocoa/procs.rkt @@ -90,8 +90,9 @@ (define (get-control-font-face) ;; Using `(tell NSFont systemFontOfSize: ...)` gives us an OS-determined ;; font, but my attempts to extract the name give something like ".LucidaGrandeUI" - ;; instead of "Lucida Grande" + ;; instead of "Lucida Grande" have failed. (cond + ;; [(version-10.11-or-later?) "San Francisco"] [(version-10.10-or-later?) "Helvetica Neue"] [else "Lucida Grande"])) (define (get-control-font-size) 13) diff --git a/gui-lib/mred/private/wx/cocoa/utils.rkt b/gui-lib/mred/private/wx/cocoa/utils.rkt index 044951da..bbfcac7f 100644 --- a/gui-lib/mred/private/wx/cocoa/utils.rkt +++ b/gui-lib/mred/private/wx/cocoa/utils.rkt @@ -25,7 +25,8 @@ version-10.6-or-later? version-10.7-or-later? version-10.9-or-later? - version-10.10-or-later?) + version-10.10-or-later? + version-10.11-or-later?) with-autorelease call-with-autorelease define-mz) @@ -86,3 +87,5 @@ (NSAppKitVersionNumber . >= . 1265)) (define (version-10.10-or-later?) (NSAppKitVersionNumber . >= . 1331)) +(define (version-10.11-or-later?) + (NSAppKitVersionNumber . >= . 1404))