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