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