figl/gl.scm

   1 ;;; figl
   2 ;;; Copyright (C) 2013 Andy Wingo <wingo@pobox.com>
   3 ;;; Copyright (C) 2013 Daniel Hartwig <mandyke@gmail.com>
   4 ;;;
   5 ;;; Figl is free software: you can redistribute it and/or modify it
   6 ;;; under the terms of the GNU Lesser General Public License as
   7 ;;; published by the Free Software Foundation, either version 3 of the
   8 ;;; License, or (at your option) any later version.
   9 ;;;
  10 ;;; Figl is distributed in the hope that it will be useful, but WITHOUT
  11 ;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  12 ;;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General
  13 ;;; Public License for more details.
  14 ;;;
  15 ;;; You should have received a copy of the GNU Lesser General Public
  16 ;;; License along with this program.  If not, see
  17 ;;; <http://www.gnu.org/licenses/>.
  18
  19 ;;; Commentary:
  20 ;;
  21 ;; OpenGL binding.
  22 ;;
  23 ;;; Code:
  24
  25 (define-module (figl gl)
  26   #:use-module (figl runtime)
  27   #:use-module (figl gl types)
  28   #:use-module (figl gl enums)
  29   #:use-module ((figl gl low-level) #:renamer (symbol-prefix-proc '%))
  30   #:use-module (system foreign))
  31
  32 ;; Notice there is no #:export clause.  Exports are done inline to
  33 ;; facilitate re-exporting low-level bindings (and changing that
  34 ;; choice), and identifying gaps in the API.
  35 ;;
  36 ;; There are two sets of exports for each section.  The first is for
  37 ;; bindings defined in the specification, exported in order.  The
  38 ;; second is for additional procedures not defined by the spec. but
  39 ;; relevant to the section, for example with-gl-begin.
  40 ;;
  41 ;; At least keep this format until the bindings are fairly complete.
  42
  43 (module-use! (module-public-interface (current-module))
  44              (resolve-interface '(figl gl enums)))
  45
  46 ;;;
  47 ;;; 2.6 Begin/End Paradigm
  48 ;;;
  49
  50 ;; emacs: (put 'gl-begin 'scheme-indent-function 1)
  51 (define-syntax gl-begin
  52   (syntax-rules ()
  53     ((_ mode body1 body2 ...)
  54      (call-with-values
  55          (lambda ()
  56            (%glBegin mode)
  57            body1 body2 ...)
  58        (lambda vals
  59          (%glEnd)
  60          (apply values vals))))))
  61
  62 (define (gl-edge-flag flag)
  63   (%glEdgeFlag (if flag (boolean true) (boolean false))))
  64
  65 (export-syntax gl-begin)
  66
  67 (export gl-edge-flag)
  68
  69 ;;;
  70 ;;; 2.7 Vertex Specification
  71 ;;;
  72
  73 ;; Note that these are float variants only.  This has implications for
  74 ;; some functions whose integer variants normalize their arguments.
  75 ;; The corresponding float variants expect normalized input, usually
  76 ;; in the range [0, 1].  Refer to the OpenGL specification for
  77 ;; details.
  78 ;;
  79 ;; For access to non-float variants please use the appropriate
  80 ;; low-level binding.
  81
  82 ;; TODO: Maybe re-export packaged variants here.  Unpacked byte
  83 ;; variants?
  84
  85 (define* (gl-vertex x y #:optional (z 0.0) (w 1.0))
  86   (%glVertex4f x y z w))
  87
  88 (define* (gl-texture-coordinate s #:optional (t 0.0) (r 0.0) (q 1.0))
  89   (%glTexCoord4f s t r q))
  90
  91 (define* (gl-multi-texture-coordinate texture s #:optional (t 0.0) (r 0.0) (q 1.0))
  92   (%glMultiTexCoord4f texture s t r q))
  93
  94 (define* (gl-color red green blue #:optional (alpha 1.0))
  95   (%glColor4f red green blue alpha))
  96
  97 (define* (gl-vertex-attribute index x #:optional (y 0.0) (z 0.0) (w 1.0))
  98   (%glVertexAttrib4f index x y z w))
  99
 100 (export gl-vertex
 101         gl-texture-coordinate
 102         gl-multi-texture-coordinate
 103         gl-color
 104         gl-vertex-attribute)
 105
 106 (re-export (%glNormal3f . gl-normal)
 107            (%glFogCoordf . gl-fog-coordinate)
 108            (%glSecondaryColor3f . gl-secondary-color)
 109            (%glIndexi . gl-index))
 110
 111 ;;;
 112 ;;; 2.8 Vertex Arrays
 113 ;;;
 114
 115
 116 (define (->pointer bv-or-pointer offset)
 117   (if (zero? offset)
 118       bv-or-pointer
 119       (bytevector->pointer bv-or-pointer offset)))
 120
 121 (define-syntax define-gl-array-setter
 122   (syntax-rules ()
 123     ((_ set-gl-foo-array glFooPointer default-size)
 124      (define* (set-gl-foo-array type bv-or-pointer
 125                                 #:optional (size default-size)
 126                                 #:key (stride 0) (offset 0))
 127        (glFooPointer size type stride
 128                      (->pointer bv-or-pointer offset))))))
 129
 130 (define-syntax define-gl-array-setters
 131   (syntax-rules ()
 132     ((_ (name binding default-size) ...)
 133      (begin
 134        (define-gl-array-setter name binding default-size)
 135        ...))))
 136
 137 (define-gl-array-setters
 138   (set-gl-vertex-array %glVertexPointer 3)
 139   (set-gl-color-array %glColorPointer 3)
 140   (set-gl-secondary-color-array %glSecondaryColorPointer 3)
 141   (set-gl-texture-coordinates-array %glTexCoordPointer 2))
 142
 143 (define* (set-gl-normal-array type bv-or-pointer
 144                               #:key (stride 0) (offset 0))
 145   (%glNormalPointer type stride
 146                     (->pointer bv-or-pointer offset)))
 147
 148 (define* (set-gl-fog-coordinate-array type bv-or-pointer #:optional
 149                                       (stride 0) (offset 0))
 150   (%glFogCoordPointer type stride
 151                       (->pointer bv-or-pointer offset)))
 152
 153 (define* (set-gl-index-array type bv-or-pointer
 154                              #:key (stride 0) (offset 0))
 155   (%glIndexPointer type stride
 156                    (->pointer bv-or-pointer offset)))
 157
 158 (define* (set-gl-vertex-attribute-array index type normalized? bv-or-pointer
 159                                         #:optional (size 4)
 160                                         #:key (stride 0) (offset 0))
 161   (%glVertexAttribPointer index size type normalized? stride
 162                           (->pointer bv-or-pointer offset)))
 163
 164 (export set-gl-vertex-array
 165         set-gl-normal-array
 166         set-gl-color-array
 167         set-gl-secondary-color-array
 168         set-gl-index-array
 169         ;; set-gl-edge-flag-array
 170         set-gl-fog-coordinate-array
 171         set-gl-texture-coordinates-array
 172         set-gl-vertex-attribute-array
 173         )
 174
 175 (re-export (%glEnableClientState . gl-enable-client-state)
 176            (%glDisableClientState . gl-disable-client-state)
 177            (%glEnableVertexAttribArray . gl-enable-vertex-attribute-array)
 178            (%glDisableVertexAttribArray . gl-disable-vertex-attribute-array)
 179            (%glClientActiveTexture . set-gl-client-active-texture))
 180
 181 (re-export (%glArrayElement . gl-array-element)
 182            (%glDrawArrays . gl-draw-arrays))
 183
 184 ;; TODO: Rest of 2.8 procedures (interleaved-arrays, etc.).
 185
 186 ;;;
 187 ;;; 2.10 Rectangles
 188 ;;;
 189
 190 (re-export (%glRectf . gl-rectangle))
 191
 192 \f
 193 ;;;
 194 ;;; 2.11 Coordinate Transformation
 195 ;;;
 196
 197 ;;;
 198 ;;; 2.11.1 Controlling the Viewport
 199 ;;;
 200
 201 (re-export (%glDepthRange . gl-depth-range)
 202            (%glViewport . gl-viewport))
 203
 204 ;;;
 205 ;;; 2.11.2 Matrices
 206 ;;;
 207
 208 ;; OpengGL matrices are stored in column-major order.  This is
 209 ;; different to the usual row-major order used in 2-dimensional
 210 ;; arrays, which will have to be transposed as they loaded.
 211
 212 (define* (gl-load-matrix m #:key (transpose #f))
 213   ((if transpose
 214        %glLoadTransposeMatrixf
 215        %glLoadMatrixf)
 216    (array-contents m)))
 217
 218 (define* (gl-multiply-matrix m #:key (transpose #f))
 219   ((if transpose
 220        %glMultTransposeMatrixf
 221        %glMultMatrixf)
 222    (array-contents m)))
 223
 224 (export gl-load-matrix
 225         gl-multiply-matrix)
 226
 227 (re-export (%glMatrixMode . set-gl-matrix-mode)
 228            (%glLoadIdentity . gl-load-identity)
 229            (%glRotatef . gl-rotate)
 230            (%glTranslatef . gl-translate)
 231            (%glScalef . gl-scale)
 232            (%glFrustum . gl-frustum)
 233            (%glOrtho . gl-ortho)
 234            (%glActiveTexture . set-gl-active-texture))
 235
 236 ;; emacs: (put 'with-gl-push-matrix 'scheme-indent-function 0)
 237 (define-syntax with-gl-push-matrix
 238   (syntax-rules ()
 239     ((_ body ...)
 240      (begin
 241        (%glPushMatrix)
 242        body ...
 243        (%glPopMatrix)))))
 244
 245 (export-syntax with-gl-push-matrix)
 246
 247 ;;;
 248 ;;; 2.11.3 Normal Transformations
 249 ;;;
 250
 251 (re-export (%glEnable . gl-enable)
 252            (%glDisable . gl-disable))
 253
 254 ;;;
 255 ;;; 2.14 Colors and Coloring
 256 ;;;
 257
 258 (re-export (%glShadeModel . set-gl-shade-model))
 259
 260 \f
 261 ;;;
 262 ;;; 4.1 Per-Fragment Operations
 263 ;;;
 264
 265 (define* (set-gl-stencil-function stencil-function k #:key
 266                                   (mask #xFFFFFFFF) ; 32-bit mask
 267                                   face)
 268   (if face
 269       (%glStencilFuncSeparate face stencil-function k mask)
 270       (%glStencilFunc stencil-function k mask)))
 271
 272 (define* (set-gl-stencil-operation stencil-fail depth-fail depth-pass #:key
 273                                    face)
 274   (if face
 275       (%glStencilOpSeparate face stencil-fail depth-fail depth-pass)
 276       (%glStencilOp stencil-fail depth-fail depth-pass)))
 277
 278 ;; TODO: 4.1.7 Occlusion Queries
 279
 280 (define* (set-gl-blend-equation mode-rgb #:optional (mode-alpha mode-rgb))
 281   (%glBlendEquationSeparate mode-rgb mode-alpha))
 282
 283 (define* (set-gl-blend-function src-rgb dest-rgb #:optional
 284                                 (src-alpha src-rgb)
 285                                 (dest-alpha dest-rgb))
 286   (%glBlendFuncSeparate src-rgb dest-rgb src-alpha dest-alpha))
 287
 288 (export set-gl-stencil-function
 289         set-gl-stencil-operation
 290         set-gl-blend-equation
 291         set-gl-blend-function
 292         )
 293
 294 (re-export (%glScissor . set-gl-scissor)
 295            (%glSampleCoverage . set-gl-sample-coverage)
 296            (%glAlphaFunc . set-gl-alpha-function)
 297            (%glDepthFunc . set-gl-depth-function)
 298            (%glBlendColor . set-gl-blend-color)
 299            (%glLogicOp . set-gl-logic-operation)
 300            )
 301
 302 ;;;
 303 ;;; 4.2 Whole Framebuffer Operations
 304 ;;;
 305
 306 (define (set-gl-draw-buffers buffers)
 307   (let* ((n (length buffers))
 308          (buffers (make-c-struct (make-list n (GLenum))
 309                                  buffers)))
 310     (%glDrawBuffers n buffers)))
 311
 312 (define* (set-gl-stencil-mask mask #:key face)
 313   (if face
 314       (%glStencilMaskSeparate face mask)
 315       (%glStencilMask mask)))
 316
 317 (export set-gl-draw-buffers
 318         set-gl-stencil-mask)
 319
 320 (re-export (%glDrawBuffer . set-gl-draw-buffer)
 321            (%glIndexMask . set-gl-index-mask)
 322            (%glColorMask . set-gl-color-mask)
 323            (%glDepthMask . set-gl-depth-mask)
 324            (%glClear . gl-clear)
 325            (%glClearColor . set-gl-clear-color)
 326            (%glClearIndex . set-gl-clear-index)
 327            (%glClearDepth . set-gl-clear-depth)
 328            (%glClearStencil . set-gl-clear-stencil-value)
 329            (%glClearAccum . set-gl-clear-accumulation-color)
 330            (%glAccum . set-gl-accumulation-buffer-operation))
 331
 332 ;;;
 333 ;;; 4.3 Drawing, Reading, and Copying Pixels
 334 ;;;
 335
 336 ;; TODO: read-pixels
 337
 338 (re-export (%glReadBuffer . set-gl-read-buffer)
 339            (%glCopyPixels . gl-copy-pixels))
 340
 341 ;;;
 342 ;;; 6.1 Querying GL State
 343 ;;;
 344
 345 ;; emacs: (put 'with-gl-push-attrib 'scheme-indent-function 1)
 346 (define-syntax-rule (with-gl-push-attrib bits body ...)
 347   (begin
 348     (%glPushAttrib bits)
 349     body
 350     ...
 351     (%glPopAttrib)))
 352
 353 (export with-gl-push-attrib)