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)))