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