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