1#lang racket/base
2(require racket/class
3         ffi/unsafe
4         ffi/unsafe/define
5         ffi/unsafe/alloc
6         "../../lock.rkt"
7         "utils.rkt"
8         racket/draw/unsafe/cairo
9         racket/draw/private/local
10         racket/draw/private/gl-context
11         racket/draw/private/gl-config
12         racket/draw/private/bitmap)
13
14(provide (protect-out create-gl-bitmap))
15
16(define cgl-lib
17  (ffi-lib "/System/Library/Frameworks/OpenGL.framework/OpenGL"))
18
19(define-ffi-definer define-cgl cgl-lib)
20
21(define _GLsizei _int)
22(define _GLenum _int)
23(define _GLboolean _bool)
24(define _GLint _int)
25(define _GLuint _uint)
26(define _CGLPixelFormatAttribute _int)
27(define _CGLError _int)
28(define _CGLPixelFormatObj (_cpointer/null 'CGLPixelFormatObj))
29(define _CGLContextObj (_cpointer/null 'CGLContextObj))
30
31(define (check-ok who r)
32  (unless (zero? r)
33    (error who "failed\n   error code: ~e" r)))
34
35(define-cgl CGLChoosePixelFormat (_fun (_list i _CGLPixelFormatAttribute)
36                                       (fmt : (_ptr o _CGLPixelFormatObj))
37                                       (n : (_ptr o _GLint))
38                                       -> (r : _CGLError)
39                                       -> (and (zero? r) fmt)))
40(define-cgl CGLDestroyPixelFormat (_fun _CGLPixelFormatObj
41                                        -> (r : _CGLError)
42                                        -> (check-ok 'CGLDestroyPixelFormat r)))
43
44(define-cgl CGLDestroyContext (_fun _CGLContextObj
45                                    -> (r : _CGLError)
46                                    -> (check-ok 'CGLDestroyContext r))
47  #:wrap (deallocator))
48(define-cgl CGLCreateContext (_fun _CGLPixelFormatObj
49                                   _CGLContextObj
50                                   (ctx : (_ptr o _CGLContextObj))
51                                   -> (r : _CGLError)
52                                   -> (and (zero? r) ctx))
53  #:wrap (allocator CGLDestroyContext))
54
55(define-cgl CGLSetOffScreen (_fun _CGLContextObj _GLsizei _GLsizei _GLsizei _pointer
56                                  -> (r : _CGLError)
57                                  -> (check-ok 'CGLSetOffScreen r)))
58
59(define-cgl CGLSetCurrentContext (_fun _CGLContextObj
60                                       -> (r : _CGLError)
61                                       -> (check-ok 'CGLSetCurrentContext r)))
62
63(define-cgl glGenFramebuffersEXT (_fun _GLint (fb : (_ptr o _GLuint))
64                                       -> _void
65                                       -> fb))
66(define-cgl glBindFramebufferEXT (_fun _GLenum _GLuint
67                                       -> _void))
68
69(define-cgl glGenRenderbuffersEXT (_fun _GLsizei (txt : (_ptr o _GLuint))
70                                        -> _void
71                                        -> txt))
72(define-cgl glBindRenderbufferEXT (_fun _GLenum _GLuint
73                                        -> _void))
74(define-cgl glRenderbufferStorageEXT (_fun _GLenum _GLenum _GLsizei _GLsizei
75                                           -> _void))
76(define-cgl glFramebufferRenderbufferEXT (_fun _GLenum _GLenum _GLenum _GLuint
77                                            -> _void))
78(define-cgl glReadPixels (_fun _GLint _GLint _GLsizei _GLsizei _GLenum _GLenum _pointer
79                               -> _void))
80
81(define GL_FRAMEBUFFER_EXT #x8D40)
82(define GL_TEXTURE_2D #x0DE1)
83(define GL_RENDERBUFFER_EXT #x8D41)
84(define GL_RGBA #x1908)
85(define GL_RGBA8 #x8058)
86(define GL_DEPTH_COMPONENT16 #x81A5)
87(define GL_UNSIGNED_BYTE #x1401)
88(define GL_COLOR_ATTACHMENT0_EXT #x8CE0)
89(define GL_DEPTH_ATTACHMENT_EXT #x8D00)
90
91(define kCGLPFAAllRenderers           1)
92(define kCGLPFADoubleBuffer           5)
93(define kCGLPFAStereo                 6)
94(define kCGLPFAAuxBuffers             7)
95(define kCGLPFAColorSize              8)
96(define kCGLPFAAlphaSize             11)
97(define kCGLPFADepthSize             12)
98(define kCGLPFAStencilSize           13)
99(define kCGLPFAAccumSize             14)
100(define kCGLPFAMinimumPolicy         51)
101(define kCGLPFAMaximumPolicy         52)
102(define kCGLPFAOffScreen             53)
103(define kCGLPFAFullScreen            54)
104(define kCGLPFASampleBuffers         55)
105(define kCGLPFASamples               56)
106(define kCGLPFAAuxDepthStencil       57)
107(define kCGLPFAColorFloat            58)
108(define kCGLPFAMultisample           59)
109(define kCGLPFASupersample           60)
110(define kCGLPFASampleAlpha           61)
111(define kCGLPFARendererID            70)
112(define kCGLPFASingleRenderer        71)
113(define kCGLPFANoRecovery            72)
114(define kCGLPFAAccelerated           73)
115(define kCGLPFAClosestPolicy         74)
116(define kCGLPFARobust                75)
117(define kCGLPFABackingStore          76)
118(define kCGLPFAMPSafe                78)
119(define kCGLPFAWindow                80)
120(define kCGLPFAMultiScreen           81)
121(define kCGLPFACompliant             83)
122(define kCGLPFADisplayMask           84)
123(define kCGLPFAPBuffer               90)
124(define kCGLPFARemotePBuffer         91)
125(define kCGLPFAAllowOfflineRenderers   96)
126(define kCGLPFAAcceleratedCompute    97)
127(define kCGLPFAOpenGLProfile         99)
128(define kCGLPFAVirtualScreenCount   128)
129
130(define kCGLOGLPVersion_Legacy #x1000)
131(define kCGLOGLPVersion_3_2_Core #x3200)
132
133(define dummy-cgl #f)
134(define current-cgl #f)
135
136(define cgl-context%
137  (let ([orig-gl-context% gl-context%])
138    (define gl-context%
139      (class orig-gl-context%
140        (init-field cgl touched)
141
142        (define/override (get-handle)
143          cgl)
144
145        (define/override (do-call-as-current t)
146          (dynamic-wind
147              (lambda ()
148                (set-box! touched #t)
149                (atomically
150                 (CGLSetCurrentContext cgl)
151                 (set! current-cgl cgl)))
152              t
153              (lambda ()
154                (atomically
155                 (CGLSetCurrentContext dummy-cgl)
156                 (set! current-cgl #f)))))
157
158        (define/override (do-swap-buffers)
159          (void))
160
161        (super-new)))
162    gl-context%))
163
164
165(define cgl-bitmap%
166  (let ([orig-bitmap% bitmap%])
167    (define bitmap%
168      (class orig-bitmap%
169        (init _cgl w h)
170        (super-make-object w h)
171
172        (define cgl _cgl)
173        (define width w)
174        (define height h)
175
176        (define bstr (make-bytes (* w h 4)))
177        (define row-bstr (make-bytes (* w 4)))
178
179        (define touched (box #f))
180
181        (define ctx (make-object cgl-context% cgl touched))
182
183        (define/override (get-bitmap-gl-context)
184          ctx)
185
186        (define/override (get-cairo-surface)
187          (surface-flush)
188          (super get-cairo-surface))
189
190        (define/override (surface-flush)
191          (when (version-10.7-or-later?)
192            (define s (super get-cairo-surface))
193            (atomically
194             (CGLSetCurrentContext cgl)
195             (glReadPixels 0 0 width height GL_RGBA GL_UNSIGNED_BYTE bstr)
196             (CGLSetCurrentContext (or current-cgl dummy-cgl)))
197            (cond
198             [(system-big-endian?)
199              ;; need ARGB
200              (for ([i (in-range 0 (* width height 4) 4)])
201                (define a (bytes-ref bstr (+ i 3)))
202                (bytes-set! bstr (+ i 1) (bytes-ref bstr i))
203                (bytes-set! bstr (+ i 2) (bytes-ref bstr (+ i 1)))
204                (bytes-set! bstr (+ i 3) (bytes-ref bstr (+ i 2)))
205                (bytes-set! bstr i a))]
206             [else
207              ;; need GBRA
208              (for ([i (in-range 0 (* width height 4) 4)])
209                (define g (bytes-ref bstr i))
210                (bytes-set! bstr i (bytes-ref bstr (+ i 2)))
211                (bytes-set! bstr (+ i 2) g))])
212            ;; flip upside-down
213            (for ([i (in-range (quotient height 2))])
214              (define above-row (ptr-add bstr (* 4 i width)))
215              (define below-row (ptr-add bstr (* 4 (- height i 1) width)))
216              (memcpy row-bstr above-row (* 4 width))
217              (memcpy above-row below-row (* 4 width))
218              (memcpy below-row row-bstr (* 4 width)))
219            ;; assuming that stride = width
220            (memcpy (cairo_image_surface_get_data s) bstr (* width height 4)))
221          (super surface-flush))
222
223        (define/override (release-bitmap-storage)
224          (set! ctx #f)
225          (super release-bitmap-storage))))
226    bitmap%))
227
228(define (create-gl-bitmap w h conf)
229  (let* ([share-context (send conf get-share-context)]
230         [context-handle (if share-context (send share-context get-handle) #f)]
231         [fmt (CGLChoosePixelFormat
232               (append
233                (if (version-10.7-or-later?)
234                    (list kCGLPFAOpenGLProfile
235                          (if (send conf get-legacy?)
236                              kCGLOGLPVersion_Legacy
237                              kCGLOGLPVersion_3_2_Core))
238                    null)
239                (list kCGLPFASampleAlpha
240                      kCGLPFAColorSize 32)
241                (if (version-10.7-or-later?)
242                    null ; must use framebuffers
243                    (list kCGLPFAOffScreen))
244                (if (send conf get-stereo) (list kCGLPFAStereo) null)
245                (list
246                 kCGLPFADepthSize (send conf get-depth-size)
247                 kCGLPFAStencilSize (send conf get-stencil-size))
248                (let ([as (send conf get-accum-size)])
249                  (if (or (version-10.7-or-later?) ; deprecated in 10.7 and later
250                          (zero? as))
251                      null
252                      (list kCGLPFAAccumSize as)))
253                (let ([ms (send conf get-multisample-size)])
254                  (if (zero? ms)
255                      null
256                      (list kCGLPFASampleBuffers 1
257                            kCGLPFASamples ms)))
258                (list 0)))])
259    (and fmt
260         (let ([cgl (CGLCreateContext fmt context-handle)]
261               [d-cgl (or dummy-cgl
262                          (let ([d (CGLCreateContext fmt #f)])
263                            (when d
264                              (set! dummy-cgl d)
265                              d)))])
266           (and cgl
267                d-cgl
268                (let ([bm (make-object cgl-bitmap% cgl w h #f #t)])
269                  (and (send bm ok?)
270                       (let ([s (send bm get-cairo-surface)])
271                         (and (cond
272                               [(version-10.7-or-later?)
273                                (atomically
274                                 (CGLSetCurrentContext cgl)
275
276                                 (define fb (glGenFramebuffersEXT 1))
277                                 (glBindFramebufferEXT GL_FRAMEBUFFER_EXT fb)
278
279                                 (define rb (glGenRenderbuffersEXT 1))
280                                 (glBindRenderbufferEXT GL_RENDERBUFFER_EXT rb)
281                                 (glRenderbufferStorageEXT GL_RENDERBUFFER_EXT GL_RGBA8 w h)
282                                 (glFramebufferRenderbufferEXT GL_FRAMEBUFFER_EXT GL_COLOR_ATTACHMENT0_EXT
283                                                               GL_RENDERBUFFER_EXT rb)
284
285                                 (unless (zero? (send conf get-depth-size))
286                                   (define rb2 (glGenRenderbuffersEXT 1))
287                                   (glBindRenderbufferEXT GL_RENDERBUFFER_EXT rb2)
288                                   (glRenderbufferStorageEXT GL_RENDERBUFFER_EXT GL_DEPTH_COMPONENT16 w h)
289                                   (glFramebufferRenderbufferEXT GL_FRAMEBUFFER_EXT GL_DEPTH_ATTACHMENT_EXT
290                                                                 GL_RENDERBUFFER_EXT rb2))
291
292                                 (CGLSetCurrentContext (or current-cgl dummy-cgl)))]
293                               [else
294                                (CGLSetOffScreen cgl w h
295                                                 (cairo_image_surface_get_stride s)
296                                                 (cairo_image_surface_get_data s))])
297                              bm)))))))))
298
299