Commit | Line | Data |
---|---|---|
6493227d AW |
1 | #!/usr/bin/env guile |
2 | !# | |
3 | ||
62c85b51 DH |
4 | ;;; figl |
5 | ;;; Copyright (C) 2013 Andy Wingo <wingo@pobox.com> | |
6 | ;;; | |
7 | ;;; Figl is free software: you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU Lesser General Public License as | |
9 | ;;; published by the Free Software Foundation, either version 3 of the | |
10 | ;;; License, or (at your option) any later version. | |
11 | ;;; | |
12 | ;;; Figl is distributed in the hope that it will be useful, but WITHOUT | |
13 | ;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY | |
14 | ;;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General | |
15 | ;;; Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU Lesser General Public | |
18 | ;;; License along with this program. If not, see | |
19 | ;;; <http://www.gnu.org/licenses/>. | |
20 | ||
6493227d AW |
21 | (use-modules (figl glut) |
22 | (figl gl) | |
23 | (figl glu) | |
24 | (ice-9 match) | |
f7443b9d AW |
25 | (ice-9 format) |
26 | (figl contrib packed-struct)) | |
6493227d | 27 | |
c71b6533 AW |
28 | (define-packed-struct color-vertex |
29 | (x float) | |
30 | (y float) | |
31 | (z float) | |
9c38a907 | 32 | |
c71b6533 AW |
33 | (r float) |
34 | (g float) | |
35 | (b float)) | |
9c38a907 AW |
36 | |
37 | (define-packed-struct particle | |
f7443b9d AW |
38 | (x float) |
39 | (y float) | |
40 | (z float) | |
41 | (vx float) | |
42 | (vy float) | |
43 | (vz float)) | |
44 | ||
c71b6533 | 45 | (define *vertices* (make-packed-array color-vertex 0)) |
9c38a907 | 46 | (define *particles* (make-packed-array particle 0)) |
6493227d AW |
47 | |
48 | (define (draw-particles) | |
9c38a907 AW |
49 | (gl-enable-client-state (enable-cap vertex-array)) |
50 | (gl-enable-client-state (enable-cap color-array)) | |
51 | (set-gl-vertex-array (vertex-pointer-type float) | |
c71b6533 AW |
52 | *vertices* |
53 | #:stride (packed-struct-size color-vertex) | |
54 | #:offset (packed-struct-offset color-vertex x)) | |
9c38a907 | 55 | (set-gl-color-array (color-pointer-type float) |
c71b6533 AW |
56 | *vertices* |
57 | #:stride (packed-struct-size color-vertex) | |
58 | #:offset (packed-struct-offset color-vertex r)) | |
54ead4dd | 59 | (gl-draw-arrays (primitive-type quads) 0 |
c71b6533 | 60 | (packed-array-length *vertices* color-vertex)) |
9c38a907 AW |
61 | (gl-disable-client-state (enable-cap color-array)) |
62 | (gl-disable-client-state (enable-cap vertex-array))) | |
f7443b9d AW |
63 | |
64 | (define (update-quads) | |
65 | (unpack-each | |
66 | *particles* | |
9c38a907 | 67 | particle |
f7443b9d AW |
68 | (lambda (n x y z vx vy vz) |
69 | (let ((r (/ (abs vx) 5)) | |
70 | (g (/ (abs vy) 5)) | |
71 | (b (/ (abs vz) 5)) | |
72 | (x- (- x 0.5)) | |
73 | (y- (- y 0.5)) | |
74 | (x+ (+ x 0.5)) | |
c71b6533 AW |
75 | (y+ (+ y 0.5)) |
76 | (base (* n 4))) | |
77 | (pack *vertices* base color-vertex | |
9c38a907 | 78 | x- y- z |
c71b6533 AW |
79 | r g b) |
80 | (pack *vertices* (+ base 1) color-vertex | |
9c38a907 | 81 | x+ y- z |
c71b6533 AW |
82 | r g b) |
83 | (pack *vertices* (+ base 2) color-vertex | |
9c38a907 | 84 | x+ y+ z |
c71b6533 AW |
85 | r g b) |
86 | (pack *vertices* (+ base 3) color-vertex | |
9c38a907 AW |
87 | x- y+ z |
88 | r g b))))) | |
6493227d AW |
89 | |
90 | (define (update-particles dt) | |
6493227d | 91 | (let ((half-dt-squared (* 0.5 dt dt))) |
f7443b9d AW |
92 | (repack-each |
93 | *particles* | |
9c38a907 | 94 | particle |
f7443b9d AW |
95 | (lambda (n x y z vx vy vz) |
96 | (let* ((distance-squared (+ (* x x) (* y y) (* z z))) | |
97 | (distance (sqrt distance-squared)) | |
98 | (F (/ -200 distance-squared)) | |
99 | (ax (* F (/ x distance))) | |
100 | (ay (* F (/ y distance))) | |
101 | (az (* F (/ z distance)))) | |
102 | (values (+ x (* vx dt) (* ax half-dt-squared)) | |
103 | (+ y (* vy dt) (* ay half-dt-squared)) | |
104 | (+ z (* vz dt) (* az half-dt-squared)) | |
105 | (+ vx (* ax dt)) | |
106 | (+ vy (* ay dt)) | |
107 | (+ vz (* az dt)))))))) | |
6493227d AW |
108 | |
109 | (define (prepare-particles n) | |
9c38a907 | 110 | (set! *particles* (make-packed-array particle n)) |
c71b6533 | 111 | (set! *vertices* (make-packed-array color-vertex (* n 4))) |
f7443b9d AW |
112 | (pack-each |
113 | *particles* | |
9c38a907 | 114 | particle |
f7443b9d AW |
115 | (lambda (n) |
116 | (values | |
117 | ;; Position. | |
118 | (* (random:normal) 30) | |
119 | (* (random:normal) 30) | |
120 | (* (random:normal) 30) | |
121 | ||
122 | ;; Velocity. | |
123 | (* (random:normal) 2) | |
124 | (* (random:normal) 2) | |
125 | (* (random:normal) 2)))) | |
126 | (update-quads)) | |
6493227d AW |
127 | |
128 | (define main-window #f) | |
129 | ||
130 | (define (make-fps-accumulator period) | |
131 | (let* ((frame-count 0) | |
132 | (last-fps-time (get-internal-real-time)) | |
133 | (last-fps-run-time (get-internal-run-time)) | |
134 | (last-frame-time (get-internal-real-time)) | |
135 | (max-frame-time (get-internal-real-time)) | |
136 | (last-frame-count 0) | |
137 | (jiffies-per-sec (exact->inexact internal-time-units-per-second)) | |
138 | (jiffies-per-ms (/ jiffies-per-sec 1000))) | |
139 | (lambda () | |
140 | (let ((now (get-internal-real-time))) | |
141 | (set! frame-count (1+ frame-count)) | |
142 | (when (> (- now last-frame-time) max-frame-time) | |
143 | (set! max-frame-time (- now last-frame-time))) | |
144 | (set! last-frame-time now) | |
145 | (when (> (- now last-fps-time) period) | |
146 | (let* ((run (get-internal-run-time)) | |
147 | (frames (- frame-count last-frame-count)) | |
148 | (secs (/ (- now last-fps-time) jiffies-per-sec)) | |
149 | (fps (/ frames secs)) | |
150 | (ms-per-frame (/ (* secs 1000) frames)) | |
151 | (max-ms-per-frame (/ max-frame-time jiffies-per-ms)) | |
152 | (cpu (* 100.0 (/ (- run last-fps-run-time) | |
153 | (- now last-fps-time))))) | |
154 | (format | |
155 | (current-error-port) | |
156 | ";;; ~a frames in ~,2f sec = ~,2f fps; ~,2f ms/frame, ~,2f ms max; ~,2f% CPU\n" | |
157 | frames secs fps ms-per-frame max-ms-per-frame cpu) | |
158 | (set! last-frame-count frame-count) | |
159 | (set! max-frame-time 0) | |
160 | (set! last-fps-time now) | |
161 | (set! last-fps-run-time run))))))) | |
162 | ||
163 | (define accumulate-fps! | |
164 | (make-fps-accumulator (* 2 internal-time-units-per-second))) | |
165 | ||
166 | (define (draw-axis scale) | |
167 | ;; Could disable lighting and depth test. | |
54ead4dd | 168 | (gl-begin (primitive-type lines) |
6493227d AW |
169 | (gl-color 1 0 0) |
170 | (gl-vertex 0 0 0) | |
171 | (gl-vertex scale 0 0) | |
172 | ||
173 | (gl-color 0 1 0) | |
174 | (gl-vertex 0 0 0) | |
175 | (gl-vertex 0 scale 0) | |
176 | ||
177 | (gl-color 0 0 1) | |
178 | (gl-vertex 0 0 0) | |
179 | (gl-vertex 0 0 scale))) | |
180 | ||
181 | (define (on-display) | |
182 | (accumulate-fps!) | |
183 | (gl-clear (clear-buffer-mask color-buffer depth-buffer)) | |
184 | ||
185 | (draw-axis 10) | |
186 | ||
187 | (draw-particles) | |
188 | ||
f7443b9d AW |
189 | ;; With double-buffering, swap-buffers will wait for the frame to be shown, |
190 | ;; which limits this program to the frame rate. | |
6493227d AW |
191 | (swap-buffers)) |
192 | ||
193 | (define (on-reshape width height) | |
194 | (pk 'reshape! width height) | |
195 | (gl-viewport 0 0 width height) | |
196 | ||
197 | ;; Projection matrix. | |
198 | (set-gl-matrix-mode (matrix-mode projection)) | |
199 | (gl-load-identity) | |
200 | (glu-perspective 60 (/ width height) 0.1 1000)) | |
201 | ||
202 | (define full-screen? #f) | |
203 | (define running? #t) | |
204 | ||
205 | (define (on-keyboard keycode x y) | |
206 | (let ((c (integer->char keycode))) | |
207 | (case c | |
208 | ((#\f) | |
209 | (set! full-screen? (not full-screen?)) | |
210 | (full-screen main-window full-screen?)) | |
211 | ((#\esc #\etx #\q) | |
212 | (format #t "~s pressed; quitting.\n" c) | |
213 | (exit)) | |
f7443b9d AW |
214 | ((#\+) |
215 | ;; The rotations are a hack to re-orient so that a translation in the Z | |
216 | ;; axis will move us towards the origin. | |
217 | (gl-rotate -10 1 0 0) | |
218 | (gl-translate 0 0 10) | |
219 | (gl-rotate 10 1 0 0)) | |
220 | ((#\-) | |
221 | (gl-rotate -10 1 0 0) | |
222 | (gl-translate 0 0 -10) | |
223 | (gl-rotate 10 1 0 0)) | |
6493227d AW |
224 | ((#\space) |
225 | (set! running? (not running?)) | |
226 | (set-idle-callback (and running? (lambda () (on-idle))))) | |
227 | (else | |
228 | (pk 'keyboard c x y))))) | |
229 | ||
230 | (define (on-special keycode x y) | |
231 | (pk 'special keycode x y)) | |
232 | ||
233 | (define (on-mouse button state x y) | |
234 | (pk 'mouse button state x y)) | |
235 | ||
236 | (define (on-motion x y) | |
237 | (pk 'motion x y)) | |
238 | ||
239 | (define (on-visibility visible?) | |
240 | (pk 'visible visible?)) | |
241 | ||
242 | (define (on-idle) | |
243 | (set-gl-matrix-mode (matrix-mode modelview)) | |
f7443b9d AW |
244 | ;; Rotate the camera 0.05 degree per frame about the Z axis. At 60 fps that's |
245 | ;; 120 seconds per full rotation. Rotating about the Z axis keeps all the | |
246 | ;; quads facing our way. | |
247 | (gl-rotate 0.05 0 0 1) | |
6493227d | 248 | (update-particles 0.016) |
f7443b9d | 249 | (update-quads) |
6493227d AW |
250 | (post-redisplay main-window)) |
251 | ||
252 | (define (register-glut-callbacks) | |
253 | ;; The trampolines allow the handlers to be overridden at runtime by | |
254 | ;; an attached Guile REPL client. | |
255 | (set-display-callback (lambda () (on-display))) | |
256 | (set-reshape-callback (lambda (w h) (on-reshape w h))) | |
257 | (set-keyboard-callback (lambda (k x y) (on-keyboard k x y))) | |
258 | (set-special-callback (lambda (k x y) (on-special k x y))) | |
259 | (set-mouse-callback (lambda (b s x y) (on-mouse b s x y))) | |
260 | (set-motion-callback (lambda (x y) (on-motion x y))) | |
261 | (set-visibility-callback (lambda (visible?) (on-visibility visible?))) | |
262 | (set-idle-callback (lambda () (on-idle)))) | |
263 | ||
264 | (define (main args) | |
265 | (let ((args | |
266 | (initialize-glut args | |
f7443b9d | 267 | #:window-size '(640 . 480) |
6493227d AW |
268 | #:display-mode (display-mode rgba alpha double |
269 | depth)))) | |
270 | (set! main-window (make-window "particle-system")) | |
271 | (register-glut-callbacks) | |
272 | (set-gl-clear-color 0 0 0 1) | |
273 | (set-gl-clear-depth 1) | |
9c38a907 | 274 | #; |
6493227d AW |
275 | (set-gl-shade-model (shading-model smooth)) |
276 | ||
277 | ;; Resetting the modelview matrix mode leaves the camera at the origin, | |
f7443b9d AW |
278 | ;; oriented to look down the Z axis. Rotate up a bit so that we can see the |
279 | ;; Z axis. | |
6493227d AW |
280 | (set-gl-matrix-mode (matrix-mode modelview)) |
281 | (gl-load-identity) | |
282 | (gl-translate 0 0 -100) | |
f7443b9d AW |
283 | (gl-rotate 10 1 0 0) |
284 | ||
285 | (gl-enable (enable-cap depth-test)) | |
6493227d AW |
286 | |
287 | (set! *random-state* (random-state-from-platform)) | |
288 | (prepare-particles (match args | |
289 | ((_) 1000) | |
290 | ((_ n) (string->number n)))) | |
291 | ||
292 | (glut-main-loop))) | |
293 | ||
294 | (when (batch-mode?) | |
295 | (exit (main (program-arguments)))) |