]> git.jsancho.org Git - gacela.git/blob - src/interfaces/opengl.scm
Replace tabs with spaces
[gacela.git] / src / interfaces / opengl.scm
1 ;;; Guile-OpenGL
2 ;;; Copyright (C) 2014 Free Software Foundation, Inc.
3 ;;; 
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.
8 ;;; 
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.
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 (define-module (gacela interfaces opengl)
19   #:use-module (glut)
20   #:use-module (gl)
21   #:use-module (glu)
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
27             draw-quad
28             draw-line
29             make-game
30             start-game
31             translate-camera
32             rotate-camera
33             full-screen))
34
35
36 ;;; Events
37
38 (define *input-events* '())
39
40 (define (clean-input-events)
41   (set! *input-events* '()))
42
43 (define (add-input-event event)
44   (set! *input-events*
45     (cons event *input-events*)))
46
47 (define (on-keyboard keycode x y)
48   (add-input-event (list 'keyboard keycode x y)))
49
50 (define (on-special keycode x y)
51   (add-input-event (list 'special keycode x y)))
52
53 (define (on-mouse button state x y)
54     (add-input-event (list 'mouse button state x y)))
55
56 (define (on-motion x y)
57     (add-input-event (list 'motion x y)))
58
59 (define (on-visibility visible?)
60     (add-input-event (list 'visible visible?)))
61
62 (define* (for-each-event proc)
63   (let loop ((events *input-events*))
64     (cond ((not (null? events))
65            (proc (car events))
66            (loop (cdr events))))))
67
68
69 ;;; Display
70
71 (define-packed-struct color-vertex
72   (x float)
73   (y float)
74   (z float)
75
76   (r float)
77   (g float)
78   (b float))
79
80 (define *vertices-list* '())
81 (define *lines-list* '())
82
83 (define (on-reshape width height)
84   (pk 'reshape! width height)
85   (gl-viewport 0 0 width height)
86
87   ;; Projection matrix.
88   (set-gl-matrix-mode (matrix-mode projection))
89   (gl-load-identity)
90   (glu-perspective 60 (/ width height) 0.1 1000))
91
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)
96                        array
97                        #:stride (packed-struct-size color-vertex)
98                        #:offset (packed-struct-offset color-vertex x))
99   (set-gl-color-array (color-pointer-type float)
100                       array
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)))
107
108 (define *display-hook* (lambda () #f))
109
110 (define (on-display)
111   (*display-hook*)
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*))
115   (swap-buffers))
116
117 (define* (draw-quad pos #:key (color '(1 1 1)) (size 1))
118   (let* ((x (car pos))
119          (y (cadr pos))
120          (z (caddr pos))
121          (delta (/ size 2.0))
122          (x- (- x delta))
123          (y- (- y delta))
124          (x+ (+ x delta))
125          (y+ (+ y delta))
126          (r (car color))
127          (g (cadr color))
128          (b (caddr color)))
129     (set! *vertices-list*
130       (append
131        (list
132         (list x- y- z r g b)
133         (list x+ y- z r g b)
134         (list x+ y+ z r g b)
135         (list x- y+ z r g b))
136        *vertices-list*))))
137
138 (define* (draw-line pos1 pos2 #:key (color '(1 1 1)))
139   (let* ((x1 (car pos1))
140          (y1 (cadr pos1))
141          (z1 (caddr pos1))
142          (x2 (car pos2))
143          (y2 (cadr pos2))
144          (z2 (caddr pos2))
145          (r (car color))
146          (g (cadr color))
147          (b (caddr color)))
148     (set! *lines-list*
149       (append
150        (list
151         (list x1 y1 z1 r g b)
152         (list x2 y2 z2 r g b))
153        *lines-list*))))
154
155 (define (add-vertex array base type vertex)
156   (let ((pos vertex)
157         (color (cdddr vertex)))
158     (pack array base type
159           (car pos) (cadr pos) (caddr pos)
160           (car color) (cadr color) (caddr color))))
161
162 (define (prepare-array vertices)
163   (let loop ((array (make-packed-array color-vertex (length vertices)))
164              (base 0)
165              (vertices vertices))
166     (cond ((null? vertices)
167            array)
168           (else
169            (let ((vertex (car vertices)))
170              (add-vertex array base color-vertex vertex))
171            (loop array (+ base 1) (cdr vertices))))))
172
173
174 ;;; Loop
175
176 (define *now* (get-internal-real-time))
177 (define *loops* 0)
178 (define *main-loop-hook* (lambda () #f))
179 (define main-window #f)
180
181 (define (on-idle)
182   (cond ((and (> (get-internal-real-time) *now*) (> 10 *loops*))
183          (set-gl-matrix-mode (matrix-mode modelview))
184          (set! *vertices-list* '())
185          (*main-loop-hook*)
186          (clean-input-events)
187          (set! *now* (+ *now* 20))
188          (set! *loops* (+ *loops* 1)))
189         (else
190          (post-redisplay main-window)
191          (set! *loops* 0))))
192
193 (define (full-screen full-screen?)
194   ((@ (glut) full-screen) main-window full-screen?))
195
196
197 ;;; Game
198
199 (define-record-type game
200   (make-game-record name)
201   game?
202   (name get-name set-name!))
203
204 (set-record-type-printer! game
205   (lambda (record port)
206     (format port "#<[game] ~a>" (get-name record))))
207
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))))
219
220 (define* (make-game name
221                     #:key
222                     (window-size '(50 . 50))
223                     (display-mode (display-mode rgba alpha double depth))
224                     (bg-color '(0 0 0 1))
225                     (depth 1)
226                     (shading-model (shading-model smooth))
227                     (main-loop-hook (lambda () #f))
228                     (display-hook (lambda () #f)))
229
230   (initialize-glut #:window-size window-size
231                    #:display-mode display-mode)
232
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)
238
239   (set-gl-matrix-mode (matrix-mode modelview))
240   (gl-load-identity)
241
242   (gl-enable (enable-cap depth-test))
243
244   (set! *main-loop-hook* main-loop-hook)
245   (set! *display-hook* display-hook)
246
247   (make-game-record name))
248
249 (define (start-game game)
250   (glut-main-loop))
251
252
253 ;;; Camera
254
255 (define (translate-camera x y z)
256   (gl-translate x y z))
257
258 (define (rotate-camera angle x y z)
259   (gl-rotate angle x y z))