figl/glut.scm

   1 ;;; figl
   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 ;; OpenGL Utility Library (GLUT) binding.
  21 ;;
  22 ;;; Code:
  23
  24 (define-module (figl glut)
  25   #:use-module (figl contrib)
  26   #:use-module ((figl glut low-level) #:renamer (symbol-prefix-proc '%))
  27   #:use-module (figl glut enums)
  28   #:use-module (system foreign)
  29   #:use-module (srfi srfi-9)
  30   #:use-module (srfi srfi-39)) ; parameter objects
  31
  32 (module-use! (module-public-interface (current-module))
  33              (resolve-interface '(figl glut enums)))
  34
  35 ;;;
  36 ;;; 2 Initialization
  37 ;;;
  38
  39 ;; TODO: Most procedures should prevent themself from being called
  40 ;; before glut-init.
  41
  42 (define glut-init? (make-parameter #f))
  43
  44 ;; Note the use of 'saved-c-strings' to keep a reference to all of the
  45 ;; C string buffers that we ever pass to 'glutInit'. This is important
  46 ;; because the glut docs specify that 'glutInit' wants the original
  47 ;; unmodified 'argv' passed to 'main', which means that it can assume
  48 ;; that the strings will never be freed. 'string->pointer' returns a C
  49 ;; string buffer managed by the garbage collector, which means that
  50 ;; the string may be freed unless the GC can see a pointer to the
  51 ;; _beginning_ of the string.
  52 (define glut-init
  53   (let ((saved-c-strings '()))
  54     (lambda (args)
  55       ;; Avoid calling init twice as GLUT will exit().
  56       (unless (glut-init?)
  57         (let* ((num-args (length args))
  58                (c-strings (map string->pointer args))
  59                (argcp (make-c-struct (list int)
  60                                      (list num-args)))
  61                (argv (make-c-struct (make-list (+ 1 num-args) '*)
  62                                     (append c-strings
  63                                             (list %null-pointer)))))
  64           (set! saved-c-strings (append c-strings saved-c-strings))
  65           (%glutInit argcp argv)
  66           (glut-init? #t)
  67           (let ((argc (car (parse-c-struct argcp (list int)))))
  68             (map pointer->string
  69                  (parse-c-struct argv
  70                                  (make-list argc '*)))))))))
  71
  72 (export glut-init)
  73
  74 (re-export (%glutInitWindowPosition . set-initial-window-position)
  75            (%glutInitWindowSize . set-initial-window-size)
  76            (%glutInitDisplayMode . set-initial-display-mode))
  77
  78 ;;;
  79 ;;; 3 Beginning Event Processing
  80 ;;;
  81
  82 (re-export (%glutMainLoop . glut-main-loop))
  83
  84 \f
  85 ;;;
  86 ;;; 4 Window Management
  87 ;;;
  88
  89 ;; Garbage collected windows are not automatically destroyed.  Permit
  90 ;; them to continue living inside GLUT.
  91
  92 (define-record-type window
  93   (%%make-window id live?)
  94   window?
  95   (id window-id)
  96   (live? window-live? set-window-live?!))
  97
  98 (define (assert-live-window! window)
  99   (unless (window-live? window)
 100     (error "window already destroyed" window)))
 101
 102 (define (top-level-window? window)
 103   (not (window-parent window)))
 104
 105 (define (sub-window? window)
 106   (and (window-parent window)
 107        #t))
 108
 109 (define (assert-top-level-window! window)
 110   (unless (top-level-window? window)
 111     (error "not a top-level window" window)))
 112
 113 ;; Memoized so state requests can return the same object.
 114 (define %make-window (memoize %%make-window))
 115
 116 (define (make-window str)
 117   (let ((id (%glutCreateWindow str)))
 118     (%make-window id #t)))
 119
 120 (define (make-sub-window window x y width height)
 121   (let ((id (%glutCreateSubWindow (window-id window) x y width height)))
 122     (%make-window id #t)))
 123
 124 (define (current-window)
 125   (let ((ret (%glutGetWindow)))
 126     (and (not (zero? ret))
 127          (%make-window ret #t))))
 128
 129 (define (set-current-window window)
 130   (assert-live-window! window)
 131   (let ((old (current-window)))
 132     (%glutSetWindow (window-id window))
 133     old))
 134
 135 (define (destroy-window window)
 136   (set-window-live?! window #f)
 137   ;; TODO: Also mark sub-windows.
 138   (%glutDestroyWindow (window-id window)))
 139
 140 ;; A short detour for some syntax forms, then most window procedures
 141 ;; operate on /either/ current-window or a specified window.
 142
 143 (define (with-window* window thunk)
 144   (let* ((swap-windows (lambda ()
 145                          (set! window (set-current-window window)))))
 146     (dynamic-wind swap-windows thunk swap-windows)))
 147
 148 ;; emacs: (put 'with-window 'scheme-indent-function 1)
 149 (define-syntax with-window
 150   (syntax-rules ()
 151     ((_ window body1 body2 ...)
 152      (with-window* window (lambda () body1 body2 ...)))))
 153
 154 ;; emacs: (put 'maybe-with-window 'scheme-indent-function 1)
 155 (define-syntax maybe-with-window
 156   (syntax-rules ()
 157     ((_ window body1 body2 ...)
 158      (if (eqv? window #t) ; use current-window
 159          (begin
 160            body1 body2 ...)
 161          (with-window window
 162            (assert-live-window! window)
 163            body1 body2 ...)))))
 164
 165 (export with-window*)
 166
 167 (export-syntax with-window)
 168
 169 ;; TODO: These post requests, and do not update the window parameters
 170 ;; immediately.  Otherwise, names like set-window-position! may be
 171 ;; more appropriate on the Scheme side.
 172
 173 (define (position-window window x y)
 174   (maybe-with-window window
 175     (%glutPositionWindow x y)))
 176
 177 (define (reshape-window window width height)
 178   (maybe-with-window window
 179     (%glutReshapeWindow width height)))
 180
 181 (define* (post-redisplay #:optional (window #t))
 182   (maybe-with-window window
 183     (%glutPostRedisplay)))
 184
 185 (define* (swap-buffers #:optional (window #t))
 186   (maybe-with-window window
 187     (%glutSwapBuffers)))
 188
 189 (define (full-screen window full-screen?)
 190   (if full-screen?
 191       (maybe-with-window window
 192         (%glutFullScreen))
 193       (error "leaving full-screen not supported")))
 194
 195 (define* (show-window #:optional (window #t))
 196   (maybe-with-window window
 197     (%glutShowWindow)))
 198
 199 (define* (hide-window #:optional (window #t))
 200   (maybe-with-window window
 201     (%glutHideWindow)))
 202
 203 (define* (iconify-window #:optional (window #t))
 204   (maybe-with-window window
 205     (%glutIconifyWindow)))
 206
 207 (define (set-window-title! window str)
 208   (assert-top-level-window! (if (eqv? window #t)
 209                                 (current-window)
 210                                 window))
 211   (maybe-with-window window
 212     (%glutSetWindowTitle str)))
 213
 214 (define (set-window-icon-title! window str)
 215   (assert-top-level-window! (if (eqv? window #t)
 216                                 (current-window)
 217                                 window))
 218   (maybe-with-window window
 219     (%glutSetIconTitle str)))
 220
 221 (define (set-window-cursor! window cursor)
 222   (maybe-with-window window
 223     (%glutSetCursor cursor)))
 224
 225 (export window?
 226         window-id
 227         top-level-window?
 228         sub-window?
 229         window-live?
 230         make-window
 231         make-sub-window
 232         current-window
 233         set-current-window
 234         destroy-window
 235         position-window
 236         reshape-window
 237         post-redisplay
 238         swap-buffers
 239         full-screen
 240         show-window
 241         hide-window
 242         iconify-window
 243         set-window-title!
 244         set-window-icon-title!
 245         set-window-cursor!)
 246
 247 (re-export (%glutPopWindow . pop-window)
 248            (%glutPushWindow . push-window))
 249
 250 \f
 251 ;;;
 252 ;;; 7 Callback Registration
 253 ;;;
 254
 255 (re-export (%glutDisplayFunc . set-display-callback)
 256            (%glutOverlayDisplayFunc . set-overlay-display-callback)
 257            (%glutReshapeFunc . set-reshape-callback)
 258            (%glutKeyboardFunc . set-keyboard-callback)
 259            (%glutMouseFunc . set-mouse-callback)
 260            (%glutMotionFunc . set-motion-callback)
 261            (%glutPassiveMotionFunc . set-passive-motion-callback)
 262            (%glutVisibilityFunc . set-visibility-callback)
 263            (%glutEntryFunc . set-entry-callback)
 264            (%glutSpecialFunc . set-special-callback)
 265            (%glutSpaceballMotionFunc . set-spaceball-motion-callback)
 266            (%glutSpaceballRotateFunc . set-spaceball-rotate-callback)
 267            (%glutSpaceballButtonFunc . set-spaceball-button-callback)
 268            (%glutButtonBoxFunc . set-button-box-callback)
 269            (%glutDialsFunc . set-dials-callback)
 270            (%glutTabletMotionFunc . set-tablet-motion-callback)
 271            (%glutTabletButtonFunc . set-tablet-button-callback)
 272            (%glutMenuStatusFunc . set-menu-status-callback)
 273            (%glutIdleFunc . set-idle-callback)
 274            (%glutTimerFunc . add-timer-callback))
 275
 276 \f
 277 ;;;
 278 ;;; 9 State Retrieval
 279 ;;;
 280
 281 ;;;
 282 ;;; 9.1 glutGet
 283 ;;;
 284
 285 (define (window-x width)
 286   (maybe-with-window window
 287     (%glutGet (glut-state window-x))))
 288
 289 (define (window-y width)
 290   (maybe-with-window window
 291     (%glutGet (glut-state window-y))))
 292
 293 (define (window-position window)
 294   (maybe-with-window window
 295     (cons (window-x #t)
 296           (window-y #t))))
 297
 298 (define (window-width width)
 299   (maybe-with-window window
 300     (%glutGet (glut-state window-width))))
 301
 302 (define (window-height width)
 303   (maybe-with-window window
 304     (%glutGet (glut-state window-height))))
 305
 306 (define (window-size window)
 307   (maybe-with-window window
 308     (cons (window-width #t)
 309           (window-height #t))))
 310
 311 (define (window-color-buffer-size window)
 312   (maybe-with-window window
 313     (%glutGet (glut-state window-buffer-size))))
 314
 315 (define (window-stencil-buffer-size window)
 316   (maybe-with-window window
 317     (%glutGet (glut-state window-stencil-size))))
 318
 319 (define (window-depth-buffer-size window)
 320   (maybe-with-window window
 321     (%glutGet (glut-state window-depth-size))))
 322
 323 (define (window-red-size window)
 324   (maybe-with-window window
 325     (%glutGet (glut-state window-red-size))))
 326
 327 (define (window-green-size window)
 328   (maybe-with-window window
 329     (%glutGet (glut-state window-green-size))))
 330
 331 (define (window-blue-size window)
 332   (maybe-with-window window
 333     (%glutGet (glut-state window-blue-size))))
 334
 335 (define (window-alpha-size window)
 336   (maybe-with-window window
 337     (%glutGet (glut-state window-alpha-size))))
 338
 339 ;; TODO: window-accum
 340
 341 (define (window-rgba? window)
 342   (maybe-with-window window
 343     (eqv? (%glutGet (glut-state window-rgba))
 344           1)))
 345
 346 (define (window-double-buffered? window)
 347   (maybe-with-window window
 348     (eqv? (%glutGet (glut-state window-doublebuffer))
 349           1)))
 350
 351 (define (window-parent window)
 352   (maybe-with-window window
 353     (let ((ret (%glutGet (glut-state window-parent))))
 354       (and (not (zero? ret))
 355            (%make-window ret #t)))))
 356
 357 (define (window-number-of-children window)
 358   (maybe-with-window window
 359     (%glutGet (glut-state window-num-children))))
 360
 361 (define (window-colormap-size window)
 362   (maybe-with-window window
 363     (%glutGet (glut-state window-colormap-size))))
 364
 365 (define (window-number-of-samples window)
 366   (maybe-with-window window
 367     (%glutGet (glut-state window-num-samples))))
 368
 369 (define (window-stereo? window)
 370   (maybe-with-window window
 371     (eqv? (%glutGet (glut-state window-stereo))
 372           1)))
 373
 374 ;; TODO: window-cursor
 375
 376 (export window-x
 377         window-y
 378         window-position
 379         window-width
 380         window-height
 381         window-size
 382         window-color-buffer-size
 383         window-stencil-buffer-size
 384         window-depth-buffer-size
 385         window-red-size
 386         window-green-size
 387         window-blue-size
 388         window-alpha-size
 389         window-rgba
 390         window-double-buffered?
 391         window-parent
 392         window-number-of-children
 393         window-colormap-size
 394         window-number-of-samples
 395         window-stereo?)
 396
 397 (define (screen-width)
 398   (let ((ret (%glutGet (glut-state screen-width))))
 399     (and (not (zero? ret))
 400          ret)))
 401
 402 (define (screen-height)
 403   (let ((ret (%glutGet (glut-state screen-height))))
 404     (and (not (zero? ret))
 405          ret)))
 406
 407 (define (screen-size)
 408   (and (screen-width)
 409        (cons (screen-width)
 410              (screen-height))))
 411
 412 (define (screen-width-mm)
 413   (let ((ret (%glutGet (glut-state screen-width-mm))))
 414     (and (not (zero? ret))
 415          ret)))
 416
 417 (define (screen-height-mm)
 418   (let ((ret (%glutGet (glut-state screen-height-mm))))
 419     (and (not (zero? ret))
 420          ret)))
 421
 422 (define (screen-size-mm)
 423   (and (screen-width-mm)
 424        (cons (screen-width-mm)
 425              (screen-height-mm))))
 426
 427 (export screen-width
 428         screen-height
 429         screen-size
 430         screen-width-mm
 431         screen-height-mm
 432         screen-size-mm)
 433
 434 ;; TODO: menu-number-of-items
 435
 436 (define (display-mode-possible?)
 437   (eqv? (%glutGet (glut-state display-mode-possible))
 438         1))
 439
 440 (define (initial-display-mode)
 441   (%glutGet (glut-state init-display-mode)))
 442
 443 (define (initial-window-x)
 444   (%glutGet (glut-state init-window-x)))
 445
 446 (define (initial-window-y)
 447   (%glutGet (glut-state init-window-y)))
 448
 449 (define (initial-window-position)
 450   (cons (initial-window-x)
 451         (initial-window-y)))
 452
 453 (define (initial-window-width)
 454   (%glutGet (glut-state init-window-width)))
 455
 456 (define (initial-window-height)
 457   (%glutGet (glut-state init-window-height)))
 458
 459 (define (initial-window-size)
 460   (cons (initial-window-width)
 461         (initial-window-height)))
 462
 463 (define (elapsed-time)
 464   (%glutGet (glut-state elapsed-time)))
 465
 466 (export display-mode-possible?
 467         initial-display-mode
 468         initial-window-x
 469         initial-window-y
 470         initial-window-position
 471         initial-window-width
 472         initial-window-height
 473         initial-window-size
 474         elapsed-time)