1#lang racket/base 2(require ffi/unsafe 3 ffi/unsafe/objc 4 ffi/unsafe/define 5 "utils.rkt" 6 "types.rkt") 7 8(provide 9 (protect-out make-gc-action-desc 10 make-gl-install 11 make-gl-uninstall 12 do-gl-action)) 13 14;; ---------------------------------------- 15;; 10.10 and earlier: change window opacity 16 17(define objc-lib (ffi-lib "libobjc")) 18 19(define msg-send-proc (get-ffi-obj 'objc_msgSend objc-lib _fpointer)) 20 21(define (make-gc-action-desc win sel val) 22 (vector 23 (vector (if (= (ctype-sizeof _CGFloat) 4) 24 'ptr_ptr_float->void 25 'ptr_ptr_double->void) 26 msg-send-proc 27 win 28 sel 29 val))) 30 31;; ---------------------------------------- 32;; 10.11 and later: OpenGL texture 33 34(define gl-lib (ffi-lib "/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL")) 35(define-ffi-definer define-gl gl-lib) 36 37(import-class NSOpenGLContext) 38 39(define _GLsizei _int) 40(define _GLint _int) 41(define _GLuint _uint) 42(define _GLenum _int) 43(define _GLbitfield _int) 44(define _GLfloat _float) 45(define _GLclampf _float) 46 47(define-gl glGenTexture (_fun (_GLsizei = 1) (v : (_ptr o _GLuint)) -> _void -> v) 48 #:c-id glGenTextures) 49(define-gl glGenLists (_fun _GLsizei -> _GLuint)) 50(define-gl glNewList (_fun _GLuint _GLenum -> _void)) 51(define-gl glEndList (_fun -> _void)) 52 53(define-gl glBindTexture (_fun _GLenum _GLuint -> _void)) 54(define-gl glTexParameteri (_fun _GLenum _GLenum _GLint -> _void)) 55(define-gl glTexImage2D (_fun _GLenum _GLint _GLint _GLsizei _GLsizei _GLint _GLenum _GLenum _pointer -> _void)) 56 57(define-gl glBegin (_fun _GLenum -> _void)) 58(define-gl glEnd (_fun -> _void)) 59(define-gl glEnable (_fun _GLenum -> _void)) 60(define-gl glDisable (_fun _GLenum -> _void)) 61 62(define-gl glMaterialfv (_fun _GLenum _GLenum (_vector i _GLfloat) -> _void)) 63(define-gl glTexCoord2f (_fun _GLfloat _GLfloat -> _void)) 64(define-gl glVertex3f (_fun _GLfloat _GLfloat _GLfloat -> _void)) 65 66(define-gl glViewport (_fun _GLint _GLint _GLsizei _GLsizei -> _void)) 67(define-gl glMatrixMode (_fun _GLenum -> _void)) 68(define-gl glLoadIdentity (_fun -> _void)) 69(define-gl glOrtho (_fun _double _double _double _double _double _double -> _void)) 70(define-gl glClearColor (_fun _GLclampf _GLclampf _GLclampf _GLclampf -> _void)) 71(define-gl glClear (_fun _GLbitfield -> _void)) 72 73(define-gl glCallList (_fun _GLint -> _void)) 74(define-gl glFlush (_fun -> _void)) 75 76(define-gl glClear-pointer _fpointer 77 #:c-id glClear) 78(define-gl glCallList-pointer _fpointer 79 #:c-id glCallList) 80(define-gl glFlush-pointer _fpointer 81 #:c-id glFlush) 82 83(define GL_TEXTURE_2D #x0DE1) 84(define GL_TEXTURE_MAG_FILTER #x2800) 85(define GL_TEXTURE_MIN_FILTER #x2801) 86(define GL_TEXTURE_WRAP_S #x2802) 87(define GL_TEXTURE_WRAP_T #x2803) 88 89(define GL_LINEAR #x2601) 90(define GL_CLAMP #x2900) 91 92(define GL_RGBA #x1908) 93 94(define GL_UNSIGNED_BYTE #x1401) 95 96(define GL_COMPILE #x1300) 97 98(define GL_FRONT #x0404) 99(define GL_AMBIENT_AND_DIFFUSE #x1602) 100 101(define GL_POLYGON #x0009) 102 103(define GL_PROJECTION #x1701) 104(define GL_MODELVIEW #x1700) 105 106(define GL_COLOR_BUFFER_BIT #x00004000) 107 108(define (make-gl-square argb uw uh backing-scale) 109 (define w (inexact->exact (ceiling (* backing-scale uw)))) 110 (define h (inexact->exact (ceiling (* backing-scale uh)))) 111 (define size (* w h 4)) 112 (define size-4 (- size 4)) 113 (define rgba (make-bytes size)) 114 (for ([x (in-range w)]) 115 (for ([y (in-range h)]) 116 (define i (* (+ x (* w y)) 4)) 117 (define j (* (+ x (* w (- h y 1))) 4)) 118 (bytes-set! rgba (+ i 3) (bytes-ref argb j)) 119 (bytes-set! rgba i (bytes-ref argb (+ j 1))) 120 (bytes-set! rgba (+ i 1) (bytes-ref argb (+ j 2))) 121 (bytes-set! rgba (+ i 2) (bytes-ref argb (+ j 3))))) 122 123 (define tex (glGenTexture)) 124 125 (glBindTexture GL_TEXTURE_2D tex) 126 (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR) 127 (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR) 128 (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP) 129 (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP) 130 (glTexImage2D GL_TEXTURE_2D 0 GL_RGBA 131 w h 0 132 GL_RGBA GL_UNSIGNED_BYTE rgba) 133 134 (define wi (exact->inexact uw)) 135 (define hi (exact->inexact uh)) 136 137 (define list-id (glGenLists 1)) 138 (glNewList list-id GL_COMPILE) 139 (glEnable GL_TEXTURE_2D) 140 (glBindTexture GL_TEXTURE_2D tex) 141 (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE (vector 1.0 1.0 1.0 1.0)) 142 (glBegin GL_POLYGON) 143 (glTexCoord2f 0.0 0.0) 144 (glVertex3f 0.0 0.0 0.0) 145 (glTexCoord2f 1.0 0.0) 146 (glVertex3f wi 0.0 0.0) 147 (glTexCoord2f 1.0 1.0) 148 (glVertex3f wi hi 0.0) 149 (glTexCoord2f 0.0 1.0) 150 (glVertex3f 0.0 hi 0.0) 151 (glEnd) 152 (glDisable GL_TEXTURE_2D) 153 (glEndList) 154 155 list-id) 156 157(define (make-gl-install win glv w h argb backing-scale) 158 (define gl (tell glv openGLContext)) 159 160 (define old-gl (tell NSOpenGLContext currentContext)) 161 (tell gl makeCurrentContext) 162 (glViewport 0 0 w h) 163 (glMatrixMode GL_PROJECTION) 164 (glLoadIdentity) 165 (glOrtho 0.0 (exact->inexact w) 0.0 (exact->inexact h) -1.0 1.0) 166 (glMatrixMode GL_MODELVIEW) 167 (glClearColor 1.0 1.0 1.0 1.0) 168 (glClear GL_COLOR_BUFFER_BIT) 169 170 (define list-id (make-gl-square argb w h backing-scale)) 171 172 (if old-gl 173 (tellv old-gl makeCurrentContext) 174 (tellv NSOpenGLContext clearCurrentContext)) 175 176 ;; The shape of this vector is parsed back out by 177 ;; `do-gl-action`, below: 178 (vector 179 (vector 'ptr_ptr->save 180 msg-send-proc 181 NSOpenGLContext 182 (selector currentContext)) 183 (vector 'ptr_ptr_ptr->void 184 msg-send-proc 185 gl 186 (selector makeCurrentContext) 187 #f) 188 (vector 'int->void 189 glClear-pointer 190 GL_COLOR_BUFFER_BIT) 191 (vector 'int->void 192 glCallList-pointer 193 list-id) 194 (vector 'int->void 195 glFlush-pointer 196 0) 197 (vector 'ptr_ptr_ptr->void 198 msg-send-proc 199 gl 200 (selector flushBuffer) 201 #f) 202 (vector 'ptr_ptr_ptr->void 203 msg-send-proc 204 NSOpenGLContext 205 (selector clearCurrentContext) 206 #f) 207 (vector 'save!_ptr->void 208 msg-send-proc 209 (selector makeCurrentContext)))) 210 211(define (make-gl-uninstall win glv w h) 212 (define gl (tell glv openGLContext)) 213 214 (vector 215 (vector 'ptr_ptr->save 216 msg-send-proc 217 NSOpenGLContext 218 (selector currentContext)) 219 (vector 'ptr_ptr_ptr->void 220 msg-send-proc 221 gl 222 (selector makeCurrentContext) 223 #f) 224 (vector 'int->void 225 glClear-pointer 226 GL_COLOR_BUFFER_BIT) 227 (vector 'int->void 228 glFlush-pointer 229 0) 230 (vector 'ptr_ptr_ptr->void 231 msg-send-proc 232 gl 233 (selector flushBuffer) 234 #f) 235 (vector 'ptr_ptr_ptr->void 236 msg-send-proc 237 NSOpenGLContext 238 (selector clearCurrentContext) 239 #f) 240 (vector 'save!_ptr->void 241 msg-send-proc 242 (selector makeCurrentContext)))) 243 244(define (do-gl-action vec) 245 (when (= 8 (vector-length vec)) 246 (define gl (vector-ref (vector-ref vec 1) 2)) 247 (define list-id (vector-ref (vector-ref vec 3) 2)) 248 249 (define old-ctx (tell NSOpenGLContext currentContext)) 250 (tellv gl makeCurrentContext) 251 (glClear GL_COLOR_BUFFER_BIT) 252 (glCallList list-id) 253 (glFlush) 254 (tellv gl flushBuffer) 255 (tellv NSOpenGLContext clearCurrentContext) 256 (when old-ctx 257 (tellv old-ctx makeCurrentContext)))) 258