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