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 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
32 (module-use! (module-public-interface (current-module))
33 (resolve-interface '(figl glut enums)))
39 ;; TODO: Most procedures should prevent themself from being called
42 (define glut-init? (make-parameter #f))
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.
53 (let ((saved-c-strings '()))
55 ;; Avoid calling init twice as GLUT will exit().
57 (let* ((num-args (length args))
58 (c-strings (map string->pointer args))
59 (argcp (make-c-struct (list int)
61 (argv (make-c-struct (make-list (+ 1 num-args) '*)
63 (list %null-pointer)))))
64 (set! saved-c-strings (append c-strings saved-c-strings))
65 (%glutInit argcp argv)
67 (let ((argc (car (parse-c-struct argcp (list int)))))
70 (make-list argc '*)))))))))
74 (re-export (%glutInitWindowPosition . set-initial-window-position)
75 (%glutInitWindowSize . set-initial-window-size)
76 (%glutInitDisplayMode . set-initial-display-mode))
79 ;;; 3 Beginning Event Processing
82 (re-export (%glutMainLoop . glut-main-loop))
86 ;;; 4 Window Management
89 ;; Garbage collected windows are not automatically destroyed. Permit
90 ;; them to continue living inside GLUT.
92 (define-record-type window
93 (%%make-window id live?)
96 (live? window-live? set-window-live?!))
98 (define (assert-live-window! window)
99 (unless (window-live? window)
100 (error "window already destroyed" window)))
102 (define (top-level-window? window)
103 (not (window-parent window)))
105 (define (sub-window? window)
106 (and (window-parent window)
109 (define (assert-top-level-window! window)
110 (unless (top-level-window? window)
111 (error "not a top-level window" window)))
113 ;; Memoized so state requests can return the same object.
114 (define %make-window (memoize %%make-window))
116 (define (make-window str)
117 (let ((id (%glutCreateWindow str)))
118 (%make-window id #t)))
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)))
124 (define (current-window)
125 (let ((ret (%glutGetWindow)))
126 (and (not (zero? ret))
127 (%make-window ret #t))))
129 (define (set-current-window window)
130 (assert-live-window! window)
131 (let ((old (current-window)))
132 (%glutSetWindow (window-id window))
135 (define (destroy-window window)
136 (set-window-live?! window #f)
137 ;; TODO: Also mark sub-windows.
138 (%glutDestroyWindow (window-id window)))
140 ;; A short detour for some syntax forms, then most window procedures
141 ;; operate on /either/ current-window or a specified window.
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)))
148 ;; emacs: (put 'with-window 'scheme-indent-function 1)
149 (define-syntax with-window
151 ((_ window body1 body2 ...)
152 (with-window* window (lambda () body1 body2 ...)))))
154 ;; emacs: (put 'maybe-with-window 'scheme-indent-function 1)
155 (define-syntax maybe-with-window
157 ((_ window body1 body2 ...)
158 (if (eqv? window #t) ; use current-window
162 (assert-live-window! window)
165 (export with-window*)
167 (export-syntax with-window)
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.
173 (define (position-window window x y)
174 (maybe-with-window window
175 (%glutPositionWindow x y)))
177 (define (reshape-window window width height)
178 (maybe-with-window window
179 (%glutReshapeWindow width height)))
181 (define* (post-redisplay #:optional (window #t))
182 (maybe-with-window window
183 (%glutPostRedisplay)))
185 (define* (swap-buffers #:optional (window #t))
186 (maybe-with-window window
189 (define (full-screen window full-screen?)
191 (maybe-with-window window
193 (error "leaving full-screen not supported")))
195 (define* (show-window #:optional (window #t))
196 (maybe-with-window window
199 (define* (hide-window #:optional (window #t))
200 (maybe-with-window window
203 (define* (iconify-window #:optional (window #t))
204 (maybe-with-window window
205 (%glutIconifyWindow)))
207 (define (set-window-title! window str)
208 (assert-top-level-window! (if (eqv? window #t)
211 (maybe-with-window window
212 (%glutSetWindowTitle str)))
214 (define (set-window-icon-title! window str)
215 (assert-top-level-window! (if (eqv? window #t)
218 (maybe-with-window window
219 (%glutSetIconTitle str)))
221 (define (set-window-cursor! window cursor)
222 (maybe-with-window window
223 (%glutSetCursor cursor)))
244 set-window-icon-title!
247 (re-export (%glutPopWindow . pop-window)
248 (%glutPushWindow . push-window))
252 ;;; 9 State Retrieval
259 (define (window-x width)
260 (maybe-with-window window
261 (%glutGet (glut-state window-x))))
263 (define (window-y width)
264 (maybe-with-window window
265 (%glutGet (glut-state window-y))))
267 (define (window-position window)
268 (maybe-with-window window
272 (define (window-width width)
273 (maybe-with-window window
274 (%glutGet (glut-state window-width))))
276 (define (window-height width)
277 (maybe-with-window window
278 (%glutGet (glut-state window-height))))
280 (define (window-size window)
281 (maybe-with-window window
282 (cons (window-width #t)
283 (window-height #t))))
285 (define (window-color-buffer-size window)
286 (maybe-with-window window
287 (%glutGet (glut-state window-buffer-size))))
289 (define (window-stencil-buffer-size window)
290 (maybe-with-window window
291 (%glutGet (glut-state window-stencil-size))))
293 (define (window-depth-buffer-size window)
294 (maybe-with-window window
295 (%glutGet (glut-state window-depth-size))))
297 (define (window-red-size window)
298 (maybe-with-window window
299 (%glutGet (glut-state window-red-size))))
301 (define (window-green-size window)
302 (maybe-with-window window
303 (%glutGet (glut-state window-green-size))))
305 (define (window-blue-size window)
306 (maybe-with-window window
307 (%glutGet (glut-state window-blue-size))))
309 (define (window-alpha-size window)
310 (maybe-with-window window
311 (%glutGet (glut-state window-alpha-size))))
313 ;; TODO: window-accum
315 (define (window-rgba? window)
316 (maybe-with-window window
317 (eqv? (%glutGet (glut-state window-rgba))
320 (define (window-double-buffered? window)
321 (maybe-with-window window
322 (eqv? (%glutGet (glut-state window-doublebuffer))
325 (define (window-parent window)
326 (maybe-with-window window
327 (let ((ret (%glutGet (glut-state window-parent))))
328 (and (not (zero? ret))
329 (%make-window ret #t)))))
331 (define (window-number-of-children window)
332 (maybe-with-window window
333 (%glutGet (glut-state window-num-children))))
335 (define (window-colormap-size window)
336 (maybe-with-window window
337 (%glutGet (glut-state window-colormap-size))))
339 (define (window-number-of-samples window)
340 (maybe-with-window window
341 (%glutGet (glut-state window-num-samples))))
343 (define (window-stereo? window)
344 (maybe-with-window window
345 (eqv? (%glutGet (glut-state window-stereo))
348 ;; TODO: window-cursor
356 window-color-buffer-size
357 window-stencil-buffer-size
358 window-depth-buffer-size
364 window-double-buffered?
366 window-number-of-children
368 window-number-of-samples
371 (define (screen-width)
372 (let ((ret (%glutGet (glut-state screen-width))))
373 (and (not (zero? ret))
376 (define (screen-height)
377 (let ((ret (%glutGet (glut-state screen-height))))
378 (and (not (zero? ret))
381 (define (screen-size)
386 (define (screen-width-mm)
387 (let ((ret (%glutGet (glut-state screen-width-mm))))
388 (and (not (zero? ret))
391 (define (screen-height-mm)
392 (let ((ret (%glutGet (glut-state screen-height-mm))))
393 (and (not (zero? ret))
396 (define (screen-size-mm)
397 (and (screen-width-mm)
398 (cons (screen-width-mm)
399 (screen-height-mm))))
408 ;; TODO: menu-number-of-items
410 (define (display-mode-possible?)
411 (eqv? (%glutGet (glut-state display-mode-possible))
414 (define (initial-display-mode)
415 (%glutGet (glut-state init-display-mode)))
417 (define (initial-window-x)
418 (%glutGet (glut-state init-window-x)))
420 (define (initial-window-y)
421 (%glutGet (glut-state init-window-y)))
423 (define (initial-window-position)
424 (cons (initial-window-x)
427 (define (initial-window-width)
428 (%glutGet (glut-state init-window-width)))
430 (define (initial-window-height)
431 (%glutGet (glut-state init-window-height)))
433 (define (initial-window-size)
434 (cons (initial-window-width)
435 (initial-window-height)))
437 (define (elapsed-time)
438 (%glutGet (glut-state elapsed-time)))
440 (export display-mode-possible?
444 initial-window-position
446 initial-window-height