figl/glut/low-level.scm

   1 ;;; fgil
   2 ;;; Copyright (C) 2013 Daniel Hartwig <mandyke@gmail.com>
   3 ;;;
   4 ;;; Figl is free software: you can redistribute it and/or modify it
   5 ;;; under the terms of the GNU Lesser General Public License as
   6 ;;; published by the Free Software Foundation, either version 3 of the
   7 ;;; License, or (at your option) any later version.
   8 ;;;
   9 ;;; Figl is distributed in the hope that it will be useful, but WITHOUT
  10 ;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  11 ;;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General
  12 ;;; Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU Lesser General Public
  15 ;;; License along with this program.  If not, see
  16 ;;; <http://www.gnu.org/licenses/>.
  17
  18 ;;; Commentary:
  19 ;;
  20 ;; These bindings are direct mappings to the OpenGL Utility Library
  21 ;; (GLUT) Programming Interface, API Version 3.
  22 ;;
  23 ;; Care should be taken to avoid errors as GLUT implementations may
  24 ;; exit() on error condition.  See section 14.3 of the specification.
  25 ;;
  26 ;;; Code:
  27
  28 (define-module (figl glut low-level)
  29   #:use-module (figl runtime)
  30   #:use-module (figl gl types)
  31   #:use-module ((system foreign) #:renamer (symbol-prefix-proc 'ffi:))
  32   #:use-module (srfi srfi-26) ; cut
  33   #:export (;; 2 Initialization
  34             glutInit
  35             glutInitWindowPosition
  36             glutInitWindowSize
  37             glutInitDisplayMode
  38
  39             ;; 3 Begin Event Processing
  40             glutMainLoop
  41
  42             ;; 4 Window Management
  43             glutCreateWindow
  44             glutCreateSubWindow
  45             glutSetWindow
  46             glutGetWindow
  47             glutDestroyWindow
  48             glutPostRedisplay
  49             glutSwapBuffers
  50             glutPositionWindow
  51             glutReshapeWindow
  52             glutFullScreen
  53             glutPopWindow
  54             glutPushWindow
  55             glutShowWindow
  56             glutHideWindow
  57             glutIconifyWindow
  58             glutSetWindowTitle
  59             glutSetIconTitle
  60             glutSetCursor
  61
  62             ;; 5 Overlay Management
  63             glutEstablishOverlay
  64             glutUseLayer
  65             glutRemoveOverlay
  66             glutPostOverlayRedisplay
  67             glutShowOverlay
  68             glutHideOverlay
  69
  70             ;; 6 Menu Management
  71             glutCreateMenu
  72             glutSetMenu
  73             glutGetMenu
  74             glutDestroyMenu
  75             glutAddMenuEntry
  76             glutAddSubMenu
  77             glutChangeToMenuEntry
  78             glutChangeToSubMenu
  79             glutRemoveMenuItem
  80             glutAttachMenu
  81             glutDetachMenu
  82
  83             ;; 7 Callback Registration
  84             glutDisplayFunc
  85             glutOverlayDisplayFunc
  86             glutReshapeFunc
  87             glutKeyboardFunc
  88             glutMouseFunc
  89             glutMotionFunc
  90             glutPassiveMotionFunc
  91             glutVisibilityFunc
  92             glutEntryFunc
  93             glutSpecialFunc
  94             glutSpaceballMotionFunc
  95             glutSpaceballRotateFunc
  96             glutSpaceballButtonFunc
  97             glutButtonBoxFunc
  98             glutDialsFunc
  99             glutTabletMotionFunc
 100             glutTabletButtonFunc
 101             glutMenuStatusFunc
 102             glutMenuStateFunc
 103             glutIdleFunc
 104             glutTimerFunc
 105
 106             ;; 8 Color Index Colormap Management
 107             glutSetColor
 108             glutGetColor
 109             glutCopyColormap
 110
 111             ;; 9 State Retrieval
 112             glutGet
 113             glutLayerGet
 114             glutDeviceGet
 115             glutGetModifiers
 116             glutExtensionSupported
 117
 118             ;; 10 Font Rendering
 119             glutBitmapCharacter
 120             glutBitmapWidth
 121             glutStrokeCharacter
 122             glutStrokeWidth
 123
 124             ;; 11 Geometric Object Rendering
 125             glutSolidSphere
 126             glutWireSphere
 127             glutSolidCube
 128             glutWireCube
 129             glutSolidCone
 130             glutWireCone
 131             glutSolidTorus
 132             glutWireTorus
 133             glutSolidDodecahedron
 134             glutWireDodecahedron
 135             glutSolidOctahedron
 136             glutWireOctahedron
 137             glutSolidTetrahedron
 138             glutWireTetrahedron
 139             glutSolidIcosahedron
 140             glutWireIcosahedron
 141             glutSolidTeapot
 142             glutWireTeapot
 143             ))
 144
 145 (define libglut (dynamic-link "libglut"))
 146
 147 (define (glut-resolver name)
 148   (dynamic-pointer name libglut))
 149
 150 (current-resolver glut-resolver)
 151
 152 (define-simple-foreign-type int ffi:int)
 153 (define-simple-foreign-type unsigned-int ffi:unsigned-int)
 154
 155 ;; GLUT specifies that all strings are ASCII encoded.
 156 (define-foreign-type char-* '*
 157   (cut ffi:string->pointer <> "ASCII")
 158   (cut ffi:pointer->string <> -1 "ASCII"))
 159
 160 (define-simple-foreign-type int-* '*)
 161 (define-simple-foreign-type char-** '*)
 162
 163 ;;;
 164 ;;; 2 Initialization
 165 ;;;
 166
 167 (define-foreign-procedure
 168   (glutInit (argcp int-*) (argv char-**) -> void)
 169   #f)
 170
 171 (define-foreign-procedure
 172   (glutInitWindowPosition (x int) (y int) -> void)
 173   #f)
 174
 175 (define-foreign-procedure
 176   (glutInitWindowSize (width int) (height int) -> void)
 177   #f)
 178
 179 (define-foreign-procedure
 180   (glutInitDisplayMode (mode unsigned-int) -> void)
 181   #f)
 182
 183 ;;;
 184 ;;; 3 Begin Event Processing
 185 ;;;
 186
 187 (define-foreign-procedure
 188   (glutMainLoop -> void)
 189   #f)
 190
 191 ;;;
 192 ;;; 4 Window Management
 193 ;;;
 194
 195 (define-foreign-procedure
 196   (glutCreateWindow (name char-*) -> int)
 197   #f)
 198
 199 (define-foreign-procedure
 200   (glutCreateSubWindow (win int)
 201                        (x int)
 202                        (y int)
 203                        (width int)
 204                        (height int)
 205                        ->
 206                        int)
 207   #f)
 208
 209 (define-foreign-procedure
 210   (glutSetWindow (win int) -> void)
 211   #f)
 212
 213 (define-foreign-procedure
 214   (glutGetWindow -> int)
 215   #f)
 216
 217 (define-foreign-procedure
 218   (glutDestroyWindow (win int) -> void)
 219   #f)
 220
 221 (define-foreign-procedure
 222   (glutPostRedisplay -> void)
 223   #f)
 224
 225 (define-foreign-procedure
 226   (glutSwapBuffers -> void)
 227   #f)
 228
 229 (define-foreign-procedure
 230   (glutPositionWindow (x int) (y int) -> void)
 231   #f)
 232
 233 (define-foreign-procedure
 234   (glutReshapeWindow (width int) (height int) -> void)
 235   #f)
 236
 237 (define-foreign-procedure
 238   (glutFullScreen -> void)
 239   #f)
 240
 241 (define-foreign-procedure
 242   (glutPopWindow -> void)
 243   #f)
 244
 245 (define-foreign-procedure
 246   (glutPushWindow -> void)
 247   #f)
 248
 249 (define-foreign-procedure
 250   (glutShowWindow -> void)
 251   #f)
 252
 253 (define-foreign-procedure
 254   (glutHideWindow -> void)
 255   #f)
 256
 257 (define-foreign-procedure
 258   (glutIconifyWindow -> void)
 259   #f)
 260
 261 (define-foreign-procedure
 262   (glutSetWindowTitle (name char-*) -> void)
 263   #f)
 264
 265 (define-foreign-procedure
 266   (glutSetIconTitle (name char-*) -> void)
 267   #f)
 268
 269 (define-foreign-procedure
 270   (glutSetCursor (cursor int) -> void)
 271   #f)
 272
 273 \f
 274 ;;;
 275 ;;; 5 Overlay Management
 276 ;;;
 277
 278 (define-foreign-procedure
 279   (glutEstablishOverlay -> void)
 280   #f)
 281
 282 (define-foreign-procedure
 283   (glutUseLayer (layer GLenum) -> void)
 284   #f)
 285
 286 (define-foreign-procedure
 287   (glutRemoveOverlay -> void)
 288   #f)
 289
 290 (define-foreign-procedure
 291   (glutPostOverlayRedisplay -> void)
 292   #f)
 293
 294 (define-foreign-procedure
 295   (glutShowOverlay -> void)
 296   #f)
 297
 298 (define-foreign-procedure
 299   (glutHideOverlay -> void)
 300   #f)
 301
 302 \f
 303 ;;;
 304 ;;; 6 Menu Management
 305 ;;;
 306
 307 (define-foreign-procedure
 308   (glutCreateMenu (func void-*) -> int)
 309   #f)
 310
 311 (define-foreign-procedure
 312   (glutSetMenu (menu int) -> void)
 313   #f)
 314
 315 (define-foreign-procedure
 316   (glutGetMenu -> int)
 317   #f)
 318
 319 (define-foreign-procedure
 320   (glutDestroyMenu (menu int) -> void)
 321   #f)
 322
 323 (define-foreign-procedure
 324   (glutAddMenuEntry (name char-*) (value int) -> void)
 325   #f)
 326
 327 (define-foreign-procedure
 328   (glutAddSubMenu (name char-*) (menu int) -> void)
 329   #f)
 330
 331 (define-foreign-procedure
 332   (glutChangeToMenuEntry (entry int)
 333                          (name char-*)
 334                          (value int)
 335                          ->
 336                          void)
 337   #f)
 338
 339 (define-foreign-procedure
 340   (glutChangeToSubMenu (entry int)
 341                        (name char-*)
 342                        (menu int)
 343                        ->
 344                        void)
 345   #f)
 346
 347 (define-foreign-procedure
 348   (glutRemoveMenuItem (entry int) -> void)
 349   #f)
 350
 351 (define-foreign-procedure
 352   (glutAttachMenu (button int) -> void)
 353   #f)
 354
 355 (define-foreign-procedure
 356   (glutDetachMenu (button int) -> void)
 357   #f)
 358
 359 \f
 360 ;;;
 361 ;;; 7 Callback Registration
 362 ;;;
 363
 364 (define-foreign-procedure
 365   (glutDisplayFunc (func void-*) -> void)
 366   #f)
 367
 368 (define-foreign-procedure
 369   (glutOverlayDisplayFunc (func void-*) -> void)
 370   #f)
 371
 372 (define-foreign-procedure
 373   (glutReshapeFunc (func void-*) -> void)
 374   #f)
 375
 376 (define-foreign-procedure
 377   (glutKeyboardFunc (func void-*) -> void)
 378   #f)
 379
 380 (define-foreign-procedure
 381   (glutMouseFunc (func void-*) -> void)
 382   #f)
 383
 384 (define-foreign-procedure
 385   (glutMotionFunc (func void-*) -> void)
 386   #f)
 387
 388 (define-foreign-procedure
 389   (glutPassiveMotionFunc (func void-*) -> void)
 390   #f)
 391
 392 (define-foreign-procedure
 393   (glutVisibilityFunc (func void-*) -> void)
 394   #f)
 395
 396 (define-foreign-procedure
 397   (glutEntryFunc (func void-*) -> void)
 398   #f)
 399
 400 (define-foreign-procedure
 401   (glutSpecialFunc (func void-*) -> void)
 402   #f)
 403
 404 (define-foreign-procedure
 405   (glutSpaceballMotionFunc (func void-*) -> void)
 406   #f)
 407
 408 (define-foreign-procedure
 409   (glutSpaceballRotateFunc (func void-*) -> void)
 410   #f)
 411
 412 (define-foreign-procedure
 413   (glutSpaceballButtonFunc (func void-*) -> void)
 414   #f)
 415
 416 (define-foreign-procedure
 417   (glutButtonBoxFunc (func void-*) -> void)
 418   #f)
 419
 420 (define-foreign-procedure
 421   (glutDialsFunc (func void-*) -> void)
 422   #f)
 423
 424 (define-foreign-procedure
 425   (glutTabletMotionFunc (func void-*) -> void)
 426   #f)
 427
 428 (define-foreign-procedure
 429   (glutTabletButtonFunc (func void-*) -> void)
 430   #f)
 431
 432 (define-foreign-procedure
 433   (glutMenuStatusFunc (func void-*) -> void)
 434   #f)
 435
 436 (define-foreign-procedure
 437   (glutMenuStateFunc (func void-*) -> void)
 438   #f)
 439
 440 (define-foreign-procedure
 441   (glutIdleFunc (func void-*) -> void)
 442   #f)
 443
 444 (define-foreign-procedure
 445   (glutTimerFunc (msecs unsigned-int)
 446                  (func void-*)
 447                  (value int)
 448                  ->
 449                  void)
 450   #f)
 451
 452 \f
 453 ;;;
 454 ;;; 8 Color Index Colormap Management
 455 ;;;
 456
 457 (define-foreign-procedure
 458   (glutSetColor (cell int)
 459                 (red GLfloat)
 460                 (green GLfloat)
 461                 (blue GLfloat)
 462                 ->
 463                 void)
 464   #f)
 465
 466 (define-foreign-procedure
 467   (glutGetColor (cell int) (component int) -> GLfloat)
 468   #f)
 469
 470 (define-foreign-procedure
 471   (glutCopyColormap (win int) -> void)
 472   #f)
 473
 474 ;;;
 475 ;;; 9 State Retrieval
 476 ;;;
 477
 478 (define-foreign-procedure
 479   (glutGet (state GLenum) -> int)
 480   #f)
 481
 482 (define-foreign-procedure
 483   (glutLayerGet (info GLenum) -> int)
 484   #f)
 485
 486 (define-foreign-procedure
 487   (glutDeviceGet (info GLenum) -> int)
 488   #f)
 489
 490 (define-foreign-procedure
 491   (glutGetModifiers -> int)
 492   #f)
 493
 494 (define-foreign-procedure
 495   (glutExtensionSupported (extension char-*) -> int)
 496   #f)
 497
 498 ;;;
 499 ;;; 10 Font Rendering
 500 ;;;
 501
 502 (define-foreign-procedure
 503   (glutBitmapCharacter (font void-*) (character int) -> void)
 504   #f)
 505
 506 (define-foreign-procedure
 507   (glutBitmapWidth (font void-*) (character int) -> int)
 508   #f)
 509
 510 (define-foreign-procedure
 511   (glutStrokeCharacter (font void-*) (character int) -> void)
 512   #f)
 513
 514 (define-foreign-procedure
 515   (glutStrokeWidth (font void-*) (character int) -> void)
 516   #f)
 517
 518 \f
 519 ;;;
 520 ;;; 11 Geometric Object Rendering
 521 ;;;
 522
 523 (define-foreign-procedure
 524   (glutSolidSphere (radius GLdouble)
 525                    (slices GLint)
 526                    (stacks GLint)
 527                    ->
 528                    void)
 529   #f)
 530
 531 (define-foreign-procedure
 532   (glutWireSphere (radius GLdouble)
 533                   (slices GLint)
 534                   (stacks GLint)
 535                   ->
 536                   void)
 537   #f)
 538
 539 (define-foreign-procedure
 540   (glutSolidCube (size GLdouble) -> void)
 541   #f)
 542
 543 (define-foreign-procedure
 544   (glutWireCube (size GLdouble) -> void)
 545   #f)
 546
 547 (define-foreign-procedure
 548   (glutSolidCone (base GLdouble)
 549                  (height GLdouble)
 550                  (slices GLint)
 551                  (stacks GLint)
 552                  ->
 553                  void)
 554   #f)
 555
 556 (define-foreign-procedure
 557   (glutWireCone (base GLdouble)
 558                 (height GLdouble)
 559                 (slices GLint)
 560                 (stacks GLint)
 561                 ->
 562                 void)
 563   #f)
 564
 565 (define-foreign-procedure
 566   (glutSolidTorus (inner-radius GLdouble)
 567                   (outer-radius GLdouble)
 568                   (sides GLint)
 569                   (rings GLint)
 570                   ->
 571                   void)
 572   #f)
 573
 574 (define-foreign-procedure
 575   (glutWireTorus (inner-radius GLdouble)
 576                  (outer-radius GLdouble)
 577                  (sides GLint)
 578                  (rings GLint)
 579                  ->
 580                  void)
 581   #f)
 582
 583 (define-foreign-procedure
 584   (glutSolidDodecahedron -> void)
 585   #f)
 586
 587 (define-foreign-procedure
 588   (glutWireDodecahedron -> void)
 589   #f)
 590
 591 (define-foreign-procedure
 592   (glutSolidOctahedron -> void)
 593   #f)
 594
 595 (define-foreign-procedure
 596   (glutWireOctahedron -> void)
 597   #f)
 598
 599 (define-foreign-procedure
 600   (glutSolidTetrahedron -> void)
 601   #f)
 602
 603 (define-foreign-procedure
 604   (glutWireTetrahedron -> void)
 605   #f)
 606
 607 (define-foreign-procedure
 608   (glutSolidIcosahedron -> void)
 609   #f)
 610
 611 (define-foreign-procedure
 612   (glutWireIcosahedron -> void)
 613   #f)
 614
 615 (define-foreign-procedure
 616   (glutSolidTeapot (size GLdouble) -> void)
 617   #f)
 618
 619 (define-foreign-procedure
 620   (glutWireTeapot (size GLdouble) -> void)
 621   #f)