1944cd8dbd
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.
263 lines
7.6 KiB
Racket
263 lines
7.6 KiB
Racket
#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-gl-install
|
|
make-gl-uninstall
|
|
do-gl-action))
|
|
|
|
;; ----------------------------------------
|
|
;; 10.10 and earlier: change window opacity
|
|
|
|
(define objc-lib (ffi-lib "libobjc"))
|
|
|
|
(define msg-send-proc (get-ffi-obj 'objc_msgSend objc-lib _fpointer))
|
|
|
|
(define-mz scheme_add_gc_callback (_fun _racket _racket -> _racket))
|
|
(define-mz scheme_remove_gc_callback (_fun _racket -> _void))
|
|
|
|
(define (make-gc-action-desc win sel val)
|
|
(vector
|
|
(vector (if (= (ctype-sizeof _CGFloat) 4)
|
|
'ptr_ptr_float->void
|
|
'ptr_ptr_double->void)
|
|
msg-send-proc
|
|
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 glCallList (_fun _GLint -> _void))
|
|
(define-gl glFlush (_fun -> _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 ([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))
|
|
|
|
(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))
|
|
|
|
;; The shape of this vector is parsed back out by
|
|
;; `do-gl-action`, below:
|
|
(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))))
|
|
|
|
(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))))
|