2 ;;; Copyright (C) 2014 Free Software Foundation, Inc.
4 ;;; Guile-OpenGL is free software: you can redistribute it and/or modify
5 ;;; it 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 ;;; Guile-OpenGL is distributed in the hope that it will be useful, but
10 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ;;; Lesser General 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/>.
18 (define-module (gacela interfaces opengl)
22 #:use-module (glu low-level)
23 #:use-module (gl contrib packed-struct)
24 #:use-module (srfi srfi-9)
25 #:use-module (srfi srfi-9 gnu)
26 #:export (for-each-event
38 (define *input-events* '())
40 (define (clean-input-events)
41 (set! *input-events* '()))
43 (define (add-input-event event)
45 (cons event *input-events*)))
47 (define (on-keyboard keycode x y)
48 (add-input-event (list 'keyboard keycode x y)))
50 (define (on-special keycode x y)
51 (add-input-event (list 'special keycode x y)))
53 (define (on-mouse button state x y)
54 (add-input-event (list 'mouse button state x y)))
56 (define (on-motion x y)
57 (add-input-event (list 'motion x y)))
59 (define (on-visibility visible?)
60 (add-input-event (list 'visible visible?)))
62 (define* (for-each-event proc)
63 (let loop ((events *input-events*))
64 (cond ((not (null? events))
66 (loop (cdr events))))))
71 (define-packed-struct color-vertex
80 (define *vertices-list* '())
81 (define *lines-list* '())
83 (define (on-reshape width height)
84 (pk 'reshape! width height)
85 (gl-viewport 0 0 width height)
88 (set-gl-matrix-mode (matrix-mode projection))
90 (glu-perspective 60 (/ width height) 0.1 1000))
92 (define (draw-vertices mode array)
93 (gl-enable-client-state (enable-cap vertex-array))
94 (gl-enable-client-state (enable-cap color-array))
95 (set-gl-vertex-array (vertex-pointer-type float)
97 #:stride (packed-struct-size color-vertex)
98 #:offset (packed-struct-offset color-vertex x))
99 (set-gl-color-array (color-pointer-type float)
101 #:stride (packed-struct-size color-vertex)
102 #:offset (packed-struct-offset color-vertex r))
103 (gl-draw-arrays mode 0
104 (packed-array-length array color-vertex))
105 (gl-disable-client-state (enable-cap color-array))
106 (gl-disable-client-state (enable-cap vertex-array)))
108 (define *display-hook* (lambda () #f))
112 (gl-clear (clear-buffer-mask color-buffer depth-buffer))
113 (draw-vertices (begin-mode quads) (prepare-array *vertices-list*))
114 (draw-vertices (begin-mode lines) (prepare-array *lines-list*))
117 (define* (draw-quad pos #:key (color '(1 1 1)) (size 1))
129 (set! *vertices-list*
135 (list x- y+ z r g b))
138 (define* (draw-line pos1 pos2 #:key (color '(1 1 1)))
139 (let* ((x1 (car pos1))
151 (list x1 y1 z1 r g b)
152 (list x2 y2 z2 r g b))
155 (define (add-vertex array base type vertex)
157 (color (cdddr vertex)))
158 (pack array base type
159 (car pos) (cadr pos) (caddr pos)
160 (car color) (cadr color) (caddr color))))
162 (define (prepare-array vertices)
163 (let loop ((array (make-packed-array color-vertex (length vertices)))
166 (cond ((null? vertices)
169 (let ((vertex (car vertices)))
170 (add-vertex array base color-vertex vertex))
171 (loop array (+ base 1) (cdr vertices))))))
176 (define *now* (get-internal-real-time))
178 (define *main-loop-hook* (lambda () #f))
179 (define main-window #f)
182 (cond ((and (> (get-internal-real-time) *now*) (> 10 *loops*))
183 (set-gl-matrix-mode (matrix-mode modelview))
184 (set! *vertices-list* '())
187 (set! *now* (+ *now* 20))
188 (set! *loops* (+ *loops* 1)))
190 (post-redisplay main-window)
193 (define (full-screen full-screen?)
194 ((@ (glut) full-screen) main-window full-screen?))
199 (define-record-type game
200 (make-game-record name)
202 (name get-name set-name!))
204 (set-record-type-printer! game
205 (lambda (record port)
206 (format port "#<[game] ~a>" (get-name record))))
208 (define (register-glut-callbacks)
209 ;; The trampolines allow the handlers to be overridden at runtime by
210 ;; an attached Guile REPL client.
211 (set-display-callback (lambda () (on-display)))
212 (set-reshape-callback (lambda (w h) (on-reshape w h)))
213 (set-keyboard-callback (lambda (k x y) (on-keyboard k x y)))
214 (set-special-callback (lambda (k x y) (on-special k x y)))
215 (set-mouse-callback (lambda (b s x y) (on-mouse b s x y)))
216 (set-motion-callback (lambda (x y) (on-motion x y)))
217 (set-visibility-callback (lambda (visible?) (on-visibility visible?)))
218 (set-idle-callback (lambda () (on-idle))))
220 (define* (make-game name
222 (window-size '(50 . 50))
223 (display-mode (display-mode rgba alpha double depth))
224 (bg-color '(0 0 0 1))
226 (shading-model (shading-model smooth))
227 (main-loop-hook (lambda () #f))
228 (display-hook (lambda () #f)))
230 (initialize-glut #:window-size window-size
231 #:display-mode display-mode)
233 (set! main-window (make-window name))
234 (register-glut-callbacks)
235 (apply set-gl-clear-color bg-color)
236 (set-gl-clear-depth depth)
237 (set-gl-shade-model shading-model)
239 (set-gl-matrix-mode (matrix-mode modelview))
242 (gl-enable (enable-cap depth-test))
244 (set! *main-loop-hook* main-loop-hook)
245 (set! *display-hook* display-hook)
247 (make-game-record name))
249 (define (start-game game)
255 (define (translate-camera x y z)
256 (gl-translate x y z))
258 (define (rotate-camera angle x y z)
259 (gl-rotate angle x y z))