5 ;;; Copyright (C) 2013 Andy Wingo <wingo@pobox.com>
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.
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.
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/>.
21 (use-modules (figl glut)
26 (figl contrib packed-struct))
28 (define-packed-struct color-vertex
37 (define-packed-struct particle
45 (define *vertices* (make-packed-array color-vertex 0))
46 (define *particles* (make-packed-array particle 0))
48 ;; Vertex buffer object.
51 (define (draw-particles)
52 (gl-bind-buffer (version-1-5 array-buffer) *vbo*)
54 (update-gl-buffer-data (version-1-5 array-buffer)
57 (gl-enable-client-state (enable-cap vertex-array))
58 (gl-enable-client-state (enable-cap color-array))
59 (set-gl-vertex-array (vertex-pointer-type float)
61 #:stride (packed-struct-size color-vertex)
62 #:offset (packed-struct-offset color-vertex x))
63 (set-gl-color-array (color-pointer-type float)
65 #:stride (packed-struct-size color-vertex)
66 #:offset (packed-struct-offset color-vertex r))
67 (gl-draw-arrays (primitive-type quads) 0
68 (packed-array-length *vertices* color-vertex))
69 (gl-disable-client-state (enable-cap color-array))
70 (gl-disable-client-state (enable-cap vertex-array))
72 (gl-bind-buffer (version-1-5 array-buffer) 0))
74 (define (update-quads)
78 (lambda (n x y z vx vy vz)
79 (let ((r (/ (abs vx) 5))
87 (pack *vertices* base color-vertex
90 (pack *vertices* (+ base 1) color-vertex
93 (pack *vertices* (+ base 2) color-vertex
96 (pack *vertices* (+ base 3) color-vertex
100 (define (update-particles dt)
101 (let ((half-dt-squared (* 0.5 dt dt)))
105 (lambda (n x y z vx vy vz)
106 (let* ((distance-squared (+ (* x x) (* y y) (* z z)))
107 (distance (sqrt distance-squared))
108 (F (/ -200 distance-squared))
109 (ax (* F (/ x distance)))
110 (ay (* F (/ y distance)))
111 (az (* F (/ z distance))))
112 (values (+ x (* vx dt) (* ax half-dt-squared))
113 (+ y (* vy dt) (* ay half-dt-squared))
114 (+ z (* vz dt) (* az half-dt-squared))
117 (+ vz (* az dt))))))))
119 (define (prepare-particles n)
120 (set! *particles* (make-packed-array particle n))
121 (set! *vertices* (make-packed-array color-vertex (* n 4)))
129 (* (random:normal) 30)
130 (* (random:normal) 30)
131 (* (random:normal) 30)
134 (* (random:normal) 2)
135 (* (random:normal) 2)
136 (* (random:normal) 2))))
140 (gl-delete-buffer *vbo*) ; no-op if 0
141 (set! *vbo* (gl-generate-buffer))
143 (gl-bind-buffer (version-1-5 array-buffer) *vbo*)
144 (set-gl-buffer-data (version-1-5 array-buffer)
146 (version-1-5 stream-draw))
147 (gl-bind-buffer (version-1-5 array-buffer) 0))
149 (define main-window #f)
151 (define (make-fps-accumulator period)
152 (let* ((frame-count 0)
153 (last-fps-time (get-internal-real-time))
154 (last-fps-run-time (get-internal-run-time))
155 (last-frame-time (get-internal-real-time))
156 (max-frame-time (get-internal-real-time))
158 (jiffies-per-sec (exact->inexact internal-time-units-per-second))
159 (jiffies-per-ms (/ jiffies-per-sec 1000)))
161 (let ((now (get-internal-real-time)))
162 (set! frame-count (1+ frame-count))
163 (when (> (- now last-frame-time) max-frame-time)
164 (set! max-frame-time (- now last-frame-time)))
165 (set! last-frame-time now)
166 (when (> (- now last-fps-time) period)
167 (let* ((run (get-internal-run-time))
168 (frames (- frame-count last-frame-count))
169 (secs (/ (- now last-fps-time) jiffies-per-sec))
170 (fps (/ frames secs))
171 (ms-per-frame (/ (* secs 1000) frames))
172 (max-ms-per-frame (/ max-frame-time jiffies-per-ms))
173 (cpu (* 100.0 (/ (- run last-fps-run-time)
174 (- now last-fps-time)))))
177 ";;; ~a frames in ~,2f sec = ~,2f fps; ~,2f ms/frame, ~,2f ms max; ~,2f% CPU\n"
178 frames secs fps ms-per-frame max-ms-per-frame cpu)
179 (set! last-frame-count frame-count)
180 (set! max-frame-time 0)
181 (set! last-fps-time now)
182 (set! last-fps-run-time run)))))))
184 (define accumulate-fps!
185 (make-fps-accumulator (* 2 internal-time-units-per-second)))
187 (define (draw-axis scale)
188 ;; Could disable lighting and depth test.
189 (gl-begin (primitive-type lines)
192 (gl-vertex scale 0 0)
196 (gl-vertex 0 scale 0)
200 (gl-vertex 0 0 scale)))
204 (gl-clear (clear-buffer-mask color-buffer depth-buffer))
210 ;; With double-buffering, swap-buffers will wait for the frame to be shown,
211 ;; which limits this program to the frame rate.
214 (define (on-reshape width height)
215 (pk 'reshape! width height)
216 (gl-viewport 0 0 width height)
218 ;; Projection matrix.
219 (set-gl-matrix-mode (matrix-mode projection))
221 (glu-perspective 60 (/ width height) 0.1 1000))
223 (define full-screen? #f)
226 (define (on-keyboard keycode x y)
227 (let ((c (integer->char keycode)))
230 (set! full-screen? (not full-screen?))
231 (full-screen main-window full-screen?))
233 (format #t "~s pressed; quitting.\n" c)
236 ;; The rotations are a hack to re-orient so that a translation in the Z
237 ;; axis will move us towards the origin.
238 (gl-rotate -10 1 0 0)
239 (gl-translate 0 0 10)
240 (gl-rotate 10 1 0 0))
242 (gl-rotate -10 1 0 0)
243 (gl-translate 0 0 -10)
244 (gl-rotate 10 1 0 0))
246 (set! running? (not running?))
247 (set-idle-callback (and running? (lambda () (on-idle)))))
249 (pk 'keyboard c x y)))))
251 (define (on-special keycode x y)
252 (pk 'special keycode x y))
254 (define (on-mouse button state x y)
255 (pk 'mouse button state x y))
257 (define (on-motion x y)
260 (define (on-visibility visible?)
261 (pk 'visible visible?))
264 (set-gl-matrix-mode (matrix-mode modelview))
265 ;; Rotate the camera 0.05 degree per frame about the Z axis. At 60 fps that's
266 ;; 120 seconds per full rotation. Rotating about the Z axis keeps all the
267 ;; quads facing our way.
268 (gl-rotate 0.05 0 0 1)
269 (update-particles 0.016)
271 (post-redisplay main-window))
273 (define (register-glut-callbacks)
274 ;; The trampolines allow the handlers to be overridden at runtime by
275 ;; an attached Guile REPL client.
276 (set-display-callback (lambda () (on-display)))
277 (set-reshape-callback (lambda (w h) (on-reshape w h)))
278 (set-keyboard-callback (lambda (k x y) (on-keyboard k x y)))
279 (set-special-callback (lambda (k x y) (on-special k x y)))
280 (set-mouse-callback (lambda (b s x y) (on-mouse b s x y)))
281 (set-motion-callback (lambda (x y) (on-motion x y)))
282 (set-visibility-callback (lambda (visible?) (on-visibility visible?)))
283 (set-idle-callback (lambda () (on-idle))))
287 (initialize-glut args
288 #:window-size '(640 . 480)
289 #:display-mode (display-mode rgba alpha double
291 (set! main-window (make-window "particle-system"))
292 (register-glut-callbacks)
293 (set-gl-clear-color 0 0 0 1)
294 (set-gl-clear-depth 1)
296 (set-gl-shade-model (shading-model smooth))
298 ;; Resetting the modelview matrix mode leaves the camera at the origin,
299 ;; oriented to look down the Z axis. Rotate up a bit so that we can see the
301 (set-gl-matrix-mode (matrix-mode modelview))
303 (gl-translate 0 0 -100)
306 (gl-enable (enable-cap depth-test))
308 (set! *random-state* (random-state-from-platform))
309 (prepare-particles (match args
311 ((_ n) (string->number n))))
316 (exit (main (program-arguments))))