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