gtk-glext: Add a forgotten with-gl-context
[cl-gtk2.git] / gtk-glext / gtkglext.lisp
1 (in-package :gtkglext)
2
3 ;; Initialization
4
5 (defcfun gtk-gl-init :void
6   (argc :pointer)
7   (argv :pointer))
8
9 (defun gl-init ()
10   (gtk-gl-init (null-pointer) (null-pointer))
11   (glut:init))
12
13 (at-init () (gl-init))
14
15 ;; Query
16
17 (defcfun (%gdk-gl-query-extension "gdk_gl_query_extension") :boolean)
18 (defcfun (%gdk-gl-query-extension-for-display "gdk_gl_query_extension_for_display") :boolean
19   (display (g-object display)))
20
21 (defun gdk-gl-query-extension (&optional (display nil display-provided-p))
22   (if display-provided-p
23       (%gdk-gl-query-extension-for-display display)
24       (%gdk-gl-query-extension)))
25
26 (export 'gdk-gl-query-extension)
27
28 (defcfun (%gdk-gl-query-version "gdk_gl_query_version") :boolean
29   (major (:pointer :int))
30   (minor (:pointer :int)))
31
32 (defcfun (%gdk-gl-query-version-for-display "gdk_gl_query_version_for_display") :boolean
33   (display (g-object display))
34   (major (:pointer :int))
35   (minor (:pointer :int)))
36
37 (defun gdk-gl-query-version (&optional (display nil display-provided-p))
38   (with-foreign-objects ((major :int) (minor :int))
39     (if display-provided-p
40         (%gdk-gl-query-version-for-display display major minor)
41         (%gdk-gl-query-version major minor))
42     (list (mem-ref major :int) (mem-ref minor :int))))
43
44 (export 'gdk-gl-query-version)
45
46 (defcfun gdk-gl-query-gl-extension :boolean
47   (extension-name :string))
48
49 (export 'gdk-gl-query-gl-extension)
50
51 ;; Tokens
52
53 (define-g-enum "GdkGLConfigAttrib" gdk-gl-config-attrib (:export t :type-initializer "gdk_gl_config_attrib_get_type")
54   (:use-gl 1) (:buffer-size 2) (:level 3)
55   (:rgba 4) (:doublebuffer 5) (:stereo 6)
56   (:aux-buffers 7) (:red-size 8) (:green-size 9)
57   (:blue-size 10) (:alpha-size 11) (:depth-size 12)
58   (:stencil-size 13) (:accum-red-size 14)
59   (:accum-green-size 15) (:accum-blue-size 16)
60   (:accum-alpha-size 17) (:config-caveat 32)
61   (:x-visual-type 34) (:transparent-type 35)
62   (:transparent-index-value 36)
63   (:transparent-red-value 37)
64   (:transparent-green-value 38)
65   (:transparent-blue-value 39)
66   (:transparent-alpha-value 40)
67   (:drawable-type 32784) (:render-type 32785)
68   (:x-renderable 32786) (:fbconfig-id 32787)
69   (:max-pbuffer-width 32790)
70   (:max-pbuffer-height 32791)
71   (:max-pbuffer-pixels 32792) (:visual-id 32779)
72   (:screen 32780) (:sample-buffers 100000)
73   (:samples 100001))
74
75 (define-g-enum "GdkGLRenderType" gdk-gl-render-type (:export t :type-initializer "gdk_gl_render_type_get_type")
76   (:rgba-type 32788) (:color-index-type 32789))
77
78 ;; Frame buffer configuration
79
80 (define-g-flags "GdkGLConfigMode" gdk-gl-config-mode (:export t :type-initializer "gdk_gl_config_mode_get_type")
81   (:rgb 0) (:rgba 0) (:index 1) (:single 0)
82   (:double 2) (:stereo 4) (:alpha 8) (:depth 16)
83   (:stencil 32) (:accum 64) (:multisample 128))
84
85 (define-g-object-class "GdkGLConfig" gdk-gl-config (:export t :type-initializer "gdk_gl_config_get_type")
86   ((:cffi screen gdk-gl-config-screen (g-object screen) "gdk_gl_config_get_screen" nil)
87    (:cffi colormap gdk-gl-config-colormap (g-object colormap) "gdk_gl_config_get_colormap" nil)
88    (:cffi visual gdk-gl-config-visual (g-object visual) "gdk_gl_config_get_visual" nil)
89    (:cffi depth gdk-gl-config-depth :int "gdk_gl_config_get_depth" nil)
90    (:cffi layer-plane gdk-gl-config-layer-plane :int "gdk_gl_config_get_layer_plane" nil)
91    (:cffi n-aux-buffers gdk-gl-config-n-aux-buffers :int "gdk_gl_config_get_n_aux_buffers" nil)
92    (:cffi n-sample-buffers gdk-gl-config-n-sample-buffers :int "gdk_gl_config_get_n_sample_buffers" nil)
93    (:cffi is-rgba gdk-gl-config-is-rgba :boolean "gdk_gl_config_is_rgba" nil)
94    (:cffi is-double-buffered gdk-gl-config-is-double-buffered :boolean "gdk_gl_config_is_double_buffered" nil)
95    (:cffi is-stereo gdk-gl-config-is-stereo :boolean "gdk_gl_config_is_stereo" nil)
96    (:cffi has-alpha gdk-gl-config-has-alpha :boolean "gdk_gl_config_has_alpha" nil)
97    (:cffi has-depth-buffer gdk-gl-config-has-depth-buffer :boolean "gdk_gl_config_has_depth_buffer" nil)
98    (:cffi has-stencil-buffer gdk-gl-config-has-stencil-buffer :boolean "gdk_gl_config_has_stencil_buffer" nil)
99    (:cffi has-accum-buffer gdk-gl-config-has-accum-buffer :boolean "gdk_gl_config_has_accum_buffer" nil)))
100
101 (defcfun (%gdk-gl-config-get-attrib "gdk_gl_config_get_attrib") :boolean
102   (gl-config (g-object gdk-gl-config))
103   (attribute gdk-gl-config-attrib)
104   (return-value (:pointer :int)))
105
106 (defun gdk-gl-config-attrib (gl-config attribute)
107   (with-foreign-object (v :int)
108     (when (%gdk-gl-config-get-attrib gl-config attribute v)
109       (mem-ref v :int))))
110
111 (defcfun gdk-gl-config-new-by-mode :pointer
112   (mode gdk-gl-config-mode))
113
114 (defcfun gdk-gl-config-new-by-mode-for-screen :pointer
115   (screen (g-object screen))
116   (mode gdk-gl-config-mode))
117
118 (defcfun (%gdk-gl-config-new-for-screen "gdk_gl_config_new_for_screen") :pointer
119   (screen (g-object screen))
120   (attrib-list (:pointer :int)))
121
122 (defun gdk-gl-config-new-for-screen (screen attrib-plist)
123   (with-foreign-object (attributes :int (+ (length attrib-plist) 2))
124     (iter (for (attr value) on attrib-plist by #'cddr)
125           (for i from 0 by 2)
126           (setf (mem-aref attributes 'gdk-gl-config-attrib i) attr
127                 (mem-aref attributes :int (1+ i)) value))
128     (%gdk-gl-config-new-for-screen screen attributes)))
129
130 (defmethod make-instance ((config-class (eql (find-class 'gdk-gl-config)))
131                           &rest initargs
132                           &key pointer screen mode attrib-plist)
133   (cond
134     (pointer (call-next-method))
135     (mode (assert (not attrib-plist) nil "MODE and ATTRIB-LIST initargs can not be combined")
136           (let ((p (if screen
137                     (gdk-gl-config-new-by-mode-for-screen screen mode)
138                     (gdk-gl-config-new-by-mode mode))))
139             (apply #'call-next-method config-class :pointer p initargs)))
140     (attrib-plist (assert screen nil "SCREEN initargs must be specified when ATTRIB-LIST is specified")
141                   (let ((p (gdk-gl-config-new-for-screen screen attrib-plist)))
142                     (apply #'call-next-method config-class :pointer p initargs)))
143     (t (error "MODE or (MODE and SCREEN) or (SCREEN and ATTRIB-PLIST) initargs must be specified"))))
144
145 ;; Render context
146
147 (define-g-object-class "GdkGLContext" gdk-gl-context  (:export t :type-initializer "gdk_gl_context_get_type")
148   ((:cffi drawable gdk-gl-context-drawable (g-object gdk-gl-drawable) "gdk_gl_context_get_gl_drawable" nil)
149    (:cffi gl-config gdk-gl-context-config (g-object gdk-gl-config) "gdk_gl_context_get_gl_config" nil)
150    (:cffi share-list gdk-gl-context-share-list (g-object gdk-gl-context) "gdk_gl_context_get_share_list" nil)
151    (:cffi is-direct gdk-gl-context-is-direct :boolean "gdk_gl_context_is_direct" nil)
152    (:cffi render-type gdk-gl-context-get-render-type gdk-gl-render-type "gdk_gl_context_get_render_type" nil)))
153
154 (defcfun (gdk-gl-context-current "gdk_gl_context_get_current") (g-object gdk-gl-context))
155
156 (export 'gdk-gl-context-current)
157
158 (defcfun gdk-gl-context-new :pointer
159   (gl-drawable (g-object gdk-gl-drawable))
160   (share-list (g-object gdk-gl-context))
161   (direct-p :boolean)
162   (render-type gdk-gl-render-type))
163
164 (defmethod make-instance ((context-class (eql (find-class 'gdk-gl-context)))
165                           &rest initargs
166                           &key pointer gl-drawable share-list direct-p (render-type :rgba-type))
167   (cond
168     (pointer (call-next-method))
169     (gl-drawable (let ((p (gdk-gl-context-new gl-drawable share-list direct-p render-type)))
170                    (apply #'call-next-method context-class :pointer p initargs)))
171     (t (error "At least GL-DRAWABLE initarg must be specified"))))
172
173 (defcfun (gdk-gl-context-copy-state "gdk_gl_context_copy") :boolean
174   (dst-gl-context (g-object gdk-gl-context))
175   (src-gl-context (g-object gdk-gl-context))
176   (attribs-mask :int)) ;;TODO: more specific enum type
177
178 (export 'gdk-gl-context-copy-state)
179
180 ;; Rendering surface
181
182 (define-g-interface "GdkGLDrawable" gdk-gl-drawable (:export t :type-initializer "gdk_gl_drawable_get_type")
183   (:cffi is-double-buffered gdk-gl-drawable-is-double-buffered :boolean "gdk_gl_drawable_is_double_buffered" nil)
184   (:cffi config gdk-gl-drawable-config (g-object gdk-gl-config) "gdk_gl_drawable_get_gl_config" nil)
185   (:cffi size gdk-gl-drawable-size list gdk-gl-drawable-size nil))
186
187 (defcfun (%gdk-gl-drawable-get-size "gdk_gl_drawable_get_size") :void
188   (gl-drawable (g-object gl-drawable))
189   (width (:pointer :int))
190   (height (:pointer :int)))
191
192 (defun gdk-gl-drawable-get-size (gl-drawable)
193   (with-foreign-objects ((width :int) (height :int))
194     (%gdk-gl-drawable-get-size gl-drawable width height)
195     (list (mem-ref width :int) (mem-ref height :int))))
196
197 (defcfun (gdk-gl-drawable-current "gdk_gl_drawable_get_current") (g-object gdk-gl-drawable))
198
199 (export 'gdk-gl-drawable-current)
200
201 (defcfun gdk-gl-drawable-swap-buffers :void
202   (gl-drawable (g-object gdk-gl-drawable)))
203
204 (export 'gdk-gl-drawable-swap-buffers)
205
206 (defcfun gdk-gl-drawable-wait-gl :void
207   (gl-drawable (g-object gdk-gl-drawable)))
208
209 (export 'gdk-gl-drawable-wait-gl)
210
211 (defcfun gdk-gl-drawable-wait-gdk :void
212   (gl-drawable (g-object gdk-gl-drawable)))
213
214 (export 'gdk-gl-drawable-wait-gdk)
215
216 (defcfun gdk-gl-drawable-gl-begin :boolean
217   (gl-drawable (g-object gdk-gl-drawable))
218   (gl-context (g-object gdk-gl-context)))
219
220 (export 'gdk-gl-drawable-gl-begin)
221
222 (defcfun gdk-gl-drawable-gl-end :void
223   (gl-drawable (g-object gdk-gl-drawable)))
224
225 (export 'gdk-gl-drawable-gl-end)
226
227 ;; OpenGL Pixmap
228
229 (define-g-object-class "GdkGLPixmap" gdk-gl-pixmap (:superclass drawable :export t :interfaces ("GdkGLDrawable"))
230   ())
231
232 (defcfun gdk-gl-pixmap-new :pointer
233   (gl-config (g-object gdk-gl-config))
234   (pixmap (g-object pixmap))
235   (attrib-list-unused (:pointer :int)))
236
237 (defmethod make-instance ((pixmap-class (eql (find-class 'gdk-gl-pixmap))) &rest initargs &key pointer gl-config pixmap)
238   (cond
239     (pointer (call-next-method))
240     ((and gl-config pixmap) (let ((p (gdk-gl-pixmap-new gl-config pixmap (null-pointer))))
241                               (apply #'call-next-method pixmap-class :pointer p initargs)))
242     (t (error "POINTER or (GL-CONFIG and PIXMAP) initargs must be specified"))))
243
244 (defcfun (%gdk-pixmap-set-gl-capability "gdk_pixmap_set_gl_capability") (g-object gdk-gl-pixmap)
245   (pixmap (g-object pixmap))
246   (gl-config (g-object gdk-gl-config))
247   (attrib-list-unused (:pointer :int)))
248
249 (defun pixmap-set-gl-capability (pixmap gl-config)
250   (%gdk-pixmap-set-gl-capability pixmap gl-config (null-pointer)))
251
252 (export 'pixmap-set-gl-capability)
253
254 (defcfun (pixmap-unset-gl-capability "gdk_pixmap_unset_gl_capability") :void
255   (pixmap (g-object pixmap)))
256
257 (export 'pixmap-unset-gl-capability)
258
259 (defcfun (pixmap-is-gl-capable "gdk_pixmap_is_gl_capable") :boolean
260   (pixmap (g-object pixmap)))
261
262 (export 'pixmap-is-gl-capable)
263
264 (defcfun (pixmap-gl-pixmap "gdk_pixmap_get_gl_pixmap") (g-object gdk-gl-pixmap)
265   (pixmap (g-object pixmap)))
266
267 (export 'pixmap-gl-pixmap)
268
269 ;; OpenGL Window
270
271 (define-g-object-class "GdkGLWindow" gdk-gl-window (:superclass drawable :export t :interfaces ("GdkGLDrawable"))
272   ((:cffi window gdk-gl-window-gdk-window (g-object gdk-window) "gdk_gl_window_get_type" nil)))
273
274 (defcfun gdk-gl-window-new :pointer
275   (gl-config (g-object gdk-gl-config))
276   (window (g-object gdk-window))
277   (attrib-list-unused (:pointer :int)))
278
279 (defmethod make-instance ((window-class (eql (find-class 'gdk-gl-window)))
280                           &rest initargs
281                           &key pointer gl-config window)
282   (cond
283     (pointer (call-next-method))
284     ((and gl-config window) (let ((p (gdk-gl-window-new gl-config window (null-pointer))))
285                               (apply #'call-next-method window-class :pointer p initargs)))
286     (t (error "POINTER or (GL-CONFIG and WINDOW) initargs must be specified"))))
287
288 (defcfun (%gdk-window-set-gl-capability "gdk_window_set_gl_capability") (g-object gdk-gl-window)
289   (window (g-object gdk-window))
290   (gl-config (g-object gdk-gl-config))
291   (attrib-list-unused (:pointer :int)))
292
293 (defun gdk-window-set-gl-capability (window gl-config)
294   (%gdk-window-set-gl-capability window gl-config (null-pointer)))
295
296 (export 'gdk-window-set-gl-capability)
297
298 (defcfun gdk-window-unset-gl-capability :void
299   (window (g-object gdk-window)))
300
301 (export 'gdk-window-unset-gl-capability)
302
303 (defcfun gdk-window-is-gl-capable :boolean
304   (window (g-object gdk-window)))
305
306 (export 'gdk-window-is-gl-capable)
307
308 (defcfun (gdk-window-gl-window "gdk_window_get_gl_window") (g-object gdk-gl-window)
309   (window (g-object gdk-window)))
310
311 (export 'gdk-window-gl-window)
312
313 ;; Font Rendering
314
315 ;; TODO: gdk_gl_font_use_pango_font
316
317 ;; TODO: gdk_gl_font_use_pango_font_for_display
318
319 ;; Geometric Object Rendering
320
321 (defcfun gdk-gl-draw-cube :void
322   (solid-p :boolean)
323   (size :double))
324
325 (export 'gdk-gl-draw-cube)
326
327 (defcfun gdk-gl-draw-sphere :void
328   (solid-p :boolean)
329   (radius :double)
330   (slices :int)
331   (stacks :int))
332
333 (export 'gdk-gl-draw-sphere)
334
335 (defcfun gdk-gl-draw-cone :void
336   (solid-p :boolean)
337   (base :double)
338   (height :double)
339   (slices :int)
340   (stacks :int))
341
342 (export 'gdk-gl-draw-cone)
343
344 (defcfun gdk-gl-draw-torus :void
345   (solid-p :boolean)
346   (inner-radius :double)
347   (outer-radius :double)
348   (n-sides :int)
349   (n-rings :int))
350
351 (export 'gdk-gl-draw-torus)
352
353 (defcfun gdk-gl-draw-tetrahedron :void
354   (solid-p :boolean))
355
356 (export 'gdk-gl-draw-tetrahedron)
357
358 (defcfun gdk-gl-draw-octahedron :void
359   (solid-p :boolean))
360
361 (export 'gdk-gl-draw-octahedron)
362
363 (defcfun gdk-gl-draw-dodecahedron :void
364   (solid-p :boolean))
365
366 (export 'gdk-gl-draw-dodecahedron)
367
368 (defcfun gdk-gl-draw-icosahedron :void
369   (solid-p :boolean))
370
371 (export 'gdk-gl-draw-icosahedron)
372
373 (defcfun gdk-gl-draw-teapot :void
374   (solid-p :boolean)
375   (scale :double))
376
377 (export 'gdk-gl-draw-teapot)
378
379 ;; OpenGL-Capable Widget
380
381 (defcfun gtk-widget-set-gl-capability :boolean
382   (widget (g-object widget))
383   (gl-config (g-object gdk-gl-config))
384   (share-list (g-object gdk-gl-config))
385   (direct-p :boolean)
386   (render-type gdk-gl-render-type))
387
388 (export 'gtk-widget-set-gl-capability)
389
390 (defcfun gtk-widget-is-gl-capable :boolean
391   (widget (g-object widget)))
392
393 (export 'gtk-widget-is-gl-capable)
394
395 (defcfun (gtk-widget-gl-config "gtk_widget_get_gl_config") (g-object gdk-gl-config)
396   (widget (g-object widget)))
397
398 (export 'gtk-widget-gl-config)
399
400 (defcfun gtk-widget-create-gl-context (g-object gdk-gl-context)
401   (widget (g-object widget))
402   (share-list (g-object gdk-gl-context))
403   (direct-p :boolean)
404   (render-type gdk-gl-render-type))
405
406 (export 'gtk-widget-create-gl-context)
407
408 (defcfun (gtk-widget-gl-context "gtk_widget_get_gl_context") (g-object gdk-gl-context)
409   (widget (g-object widget)))
410
411 (export 'gtk-widget-gl-context)
412
413 (defcfun (gtk-widget-gl-window "gtk_widget_get_gl_window") (g-object gdk-gl-window)
414   (widget (g-object widget)))
415
416 (export 'gtk-widget-gl-window)
417
418 (defun get-gl-config-ptr ()
419   (let ((cfg (gdk-gl-config-new-by-mode '(:rgba :depth :double))))
420     (if (null-pointer-p cfg)
421         (let ((cfg (gdk-gl-config-new-by-mode '(:rgba :depth))))
422           (warn "No double buffered visual found.  Trying single-buffered.")
423           (if (null-pointer-p cfg)
424               (error "No OpenGL capable visual found.")
425               cfg))
426         cfg)))
427
428 (defun get-gl-config ()
429   (make-instance 'gdk-gl-config :pointer (get-gl-config-ptr)))
430
431 (defvar *gl-config* nil)
432
433 (at-init () (setf *gl-config* (get-gl-config)))
434
435 (defmacro with-gensyms (syms &body body)
436   "Paul Graham ON LISP pg 145. Used in macros to avoid variable capture."
437   `(let ,(mapcar #'(lambda (s)
438                      `(,s (gensym)))
439           syms)
440      ,@body))
441
442 (defmacro bwhen ((bindvar boundform) &body body)
443   `(let ((,bindvar ,boundform))
444       (when ,bindvar
445         ,@body)))
446
447 (defmacro with-gl-context ((widget &key (swap-buffers-p t)) &rest body)
448   (with-gensyms (drawable context swap-p w)
449     `(let ((,swap-p ,swap-buffers-p)
450            (,w ,widget))
451        (let ((,context (gtk-widget-gl-context ,w))
452              (,drawable (gtk-widget-gl-window ,w)))
453          (if (and ,context ,drawable (gdk-gl-drawable-gl-begin ,drawable ,context))
454              (unwind-protect
455                   ,@body
456                (progn
457                  (when ,swap-p
458                    (when (gdk-gl-drawable-is-double-buffered ,drawable)
459                      (gdk-gl-drawable-swap-buffers ,drawable)))
460                  (gdk-gl-drawable-gl-end ,drawable)))
461              (format t "gl-begin failed ~A ~A ~A~%" ,w ,drawable ,context))))))
462
463 (defmacro with-matrix-mode ((mode) &body body)
464   `(progn
465      (gl:matrix-mode ,mode)
466      (gl:load-identity)
467      ,@body
468      (gl:matrix-mode :modelview)
469      (gl:load-identity)))