2 ;;; Copyright (C) 2013 Daniel Hartwig <mandyke@gmail.com>
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.
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.
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/>.
20 ;; OpenGL Utility Library (GLUT) binding.
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
33 (module-use! (module-public-interface (current-module))
34 (resolve-interface '(figl glut enums)))
40 (define (set-initial-window-position position)
41 (%glutInitWindowPosition (car position) (cdr position)))
43 (define (set-initial-window-size size)
44 (%glutInitWindowSize (car size) (cdr size)))
46 (export set-initial-window-position
47 set-initial-window-size)
49 (re-export (%glutInitDisplayMode . set-initial-display-mode))
51 (define glut-init? #f)
53 (define saved-c-strings '())
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.
64 (define* (initialize-glut #:optional (args (program-arguments))
65 #:key window-position window-size display-mode)
67 (error "GLUT already initialized"))
70 (%glutInitWindowPosition (car window-position) (cdr window-position)))
73 (%glutInitWindowSize (car window-size) (cdr window-size)))
76 (%glutInitDisplayMode display-mode))
78 (let* ((num-args (length args))
79 (c-strings (map string->pointer args))
80 (argcp (make-c-struct (list int)
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)
87 (let ((argc (car (parse-c-struct argcp (list int)))))
90 (make-list argc '*))))))
92 (add-hook! *resolve-hook*
94 (unless (or glut-init? (string-prefix? "glutInit" name))
97 (export initialize-glut)
101 ;;; 3 Beginning Event Processing
104 (re-export (%glutMainLoop . glut-main-loop))
108 ;;; 4 Window Management
111 ;; Garbage collected windows are not automatically destroyed. Permit
112 ;; them to continue living inside GLUT.
114 (define-record-type window
115 (%%make-window id live?)
118 (live? window-live? set-window-live?!))
120 (define (assert-live-window! window)
121 (unless (window-live? window)
122 (error "window already destroyed" window)))
124 (define (top-level-window? window)
125 (not (window-parent window)))
127 (define (sub-window? window)
128 (and (window-parent window)
131 (define (assert-top-level-window! window)
132 (unless (top-level-window? window)
133 (error "not a top-level window" window)))
135 ;; Memoized so state requests can return the same object.
136 (define %make-window (memoize %%make-window))
138 (define (make-window str)
139 (let ((id (%glutCreateWindow str)))
140 (%make-window id #t)))
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)))
146 (define (current-window)
147 (let ((ret (%glutGetWindow)))
148 (and (not (zero? ret))
149 (%make-window ret #t))))
151 (define (set-current-window window)
152 (assert-live-window! window)
153 (let ((old (current-window)))
154 (%glutSetWindow (window-id window))
157 (define (destroy-window window)
158 (set-window-live?! window #f)
159 ;; TODO: Also mark sub-windows.
160 (%glutDestroyWindow (window-id window)))
162 ;; A short detour for some syntax forms, then most window procedures
163 ;; operate on /either/ current-window or a specified window.
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)))
170 ;; emacs: (put 'with-window 'scheme-indent-function 1)
171 (define-syntax with-window
173 ((_ window body1 body2 ...)
174 (with-window* window (lambda () body1 body2 ...)))))
176 ;; emacs: (put 'maybe-with-window 'scheme-indent-function 1)
177 (define-syntax maybe-with-window
179 ((_ window body1 body2 ...)
180 (if (eqv? window #t) ; use current-window
184 (assert-live-window! window)
187 (export with-window*)
189 (export-syntax with-window)
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.
195 (define (position-window window x y)
196 (maybe-with-window window
197 (%glutPositionWindow x y)))
199 (define (reshape-window window width height)
200 (maybe-with-window window
201 (%glutReshapeWindow width height)))
203 (define* (post-redisplay #:optional (window #t))
204 (maybe-with-window window
205 (%glutPostRedisplay)))
207 (define* (swap-buffers #:optional (window #t))
208 (maybe-with-window window
211 (define (full-screen window full-screen?)
213 (maybe-with-window window
215 (error "leaving full-screen not supported")))
217 (define* (show-window #:optional (window #t))
218 (maybe-with-window window
221 (define* (hide-window #:optional (window #t))
222 (maybe-with-window window
225 (define* (iconify-window #:optional (window #t))
226 (maybe-with-window window
227 (%glutIconifyWindow)))
229 (define (set-window-title! window str)
230 (assert-top-level-window! (if (eqv? window #t)
233 (maybe-with-window window
234 (%glutSetWindowTitle str)))
236 (define (set-window-icon-title! window str)
237 (assert-top-level-window! (if (eqv? window #t)
240 (maybe-with-window window
241 (%glutSetIconTitle str)))
243 (define (set-window-cursor! window cursor)
244 (maybe-with-window window
245 (%glutSetCursor cursor)))
266 set-window-icon-title!
269 (re-export (%glutPopWindow . pop-window)
270 (%glutPushWindow . push-window))
274 ;;; 7 Callback Registration
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))
299 ;;; 9 State Retrieval
306 (define (window-x width)
307 (maybe-with-window window
308 (%glutGet (glut-state window-x))))
310 (define (window-y width)
311 (maybe-with-window window
312 (%glutGet (glut-state window-y))))
314 (define (window-position window)
315 (maybe-with-window window
319 (define (window-width width)
320 (maybe-with-window window
321 (%glutGet (glut-state window-width))))
323 (define (window-height width)
324 (maybe-with-window window
325 (%glutGet (glut-state window-height))))
327 (define (window-size window)
328 (maybe-with-window window
329 (cons (window-width #t)
330 (window-height #t))))
332 (define (window-color-buffer-size window)
333 (maybe-with-window window
334 (%glutGet (glut-state window-buffer-size))))
336 (define (window-stencil-buffer-size window)
337 (maybe-with-window window
338 (%glutGet (glut-state window-stencil-size))))
340 (define (window-depth-buffer-size window)
341 (maybe-with-window window
342 (%glutGet (glut-state window-depth-size))))
344 (define (window-red-size window)
345 (maybe-with-window window
346 (%glutGet (glut-state window-red-size))))
348 (define (window-green-size window)
349 (maybe-with-window window
350 (%glutGet (glut-state window-green-size))))
352 (define (window-blue-size window)
353 (maybe-with-window window
354 (%glutGet (glut-state window-blue-size))))
356 (define (window-alpha-size window)
357 (maybe-with-window window
358 (%glutGet (glut-state window-alpha-size))))
360 ;; TODO: window-accum
362 (define (window-rgba? window)
363 (maybe-with-window window
364 (eqv? (%glutGet (glut-state window-rgba))
367 (define (window-double-buffered? window)
368 (maybe-with-window window
369 (eqv? (%glutGet (glut-state window-doublebuffer))
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)))))
378 (define (window-number-of-children window)
379 (maybe-with-window window
380 (%glutGet (glut-state window-num-children))))
382 (define (window-colormap-size window)
383 (maybe-with-window window
384 (%glutGet (glut-state window-colormap-size))))
386 (define (window-number-of-samples window)
387 (maybe-with-window window
388 (%glutGet (glut-state window-num-samples))))
390 (define (window-stereo? window)
391 (maybe-with-window window
392 (eqv? (%glutGet (glut-state window-stereo))
395 ;; TODO: window-cursor
403 window-color-buffer-size
404 window-stencil-buffer-size
405 window-depth-buffer-size
411 window-double-buffered?
413 window-number-of-children
415 window-number-of-samples
418 (define (screen-width)
419 (let ((ret (%glutGet (glut-state screen-width))))
420 (and (not (zero? ret))
423 (define (screen-height)
424 (let ((ret (%glutGet (glut-state screen-height))))
425 (and (not (zero? ret))
428 (define (screen-size)
433 (define (screen-width-mm)
434 (let ((ret (%glutGet (glut-state screen-width-mm))))
435 (and (not (zero? ret))
438 (define (screen-height-mm)
439 (let ((ret (%glutGet (glut-state screen-height-mm))))
440 (and (not (zero? ret))
443 (define (screen-size-mm)
444 (and (screen-width-mm)
445 (cons (screen-width-mm)
446 (screen-height-mm))))
455 ;; TODO: menu-number-of-items
457 (define (display-mode-possible?)
458 (eqv? (%glutGet (glut-state display-mode-possible))
461 (define (initial-display-mode)
462 (%glutGet (glut-state init-display-mode)))
464 (define (initial-window-x)
465 (%glutGet (glut-state init-window-x)))
467 (define (initial-window-y)
468 (%glutGet (glut-state init-window-y)))
470 (define (initial-window-position)
471 (cons (initial-window-x)
474 (define (initial-window-width)
475 (%glutGet (glut-state init-window-width)))
477 (define (initial-window-height)
478 (%glutGet (glut-state init-window-height)))
480 (define (initial-window-size)
481 (cons (initial-window-width)
482 (initial-window-height)))
484 (define (elapsed-time)
485 (%glutGet (glut-state elapsed-time)))
487 (export display-mode-possible?
491 initial-window-position
493 initial-window-height