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