add particle system example using vertex buffer objects

* examples/particle-system/vbo.scm: New example, using vertex buffer
  objects.

diff --git a/examples/particle-system/vbo.scm b/examples/particle-system/vbo.scm
new file mode 100644 (file)
index 0000000..dabb096
--- /dev/null
+++ b/examples/particle-system/vbo.scm
@@ -0,0 +1,299 @@
+#!/usr/bin/env guile
+!#
+
+(use-modules (figl glut)
+             (figl gl)
+             (figl glu)
+             (ice-9 match)
+             (ice-9 format)
+             (figl contrib packed-struct))
+
+(define-packed-struct color-vertex
+  (x float)
+  (y float)
+  (z float)
+
+  (r float)
+  (g float)
+  (b float))
+
+(define-packed-struct particle
+  (x float)
+  (y float)
+  (z float)
+  (vx float)
+  (vy float)
+  (vz float))
+
+(define *vertices* (make-packed-array color-vertex 0))
+(define *particles* (make-packed-array particle 0))
+
+;; Vertex buffer object.
+(define *vbo* 0)
+
+(define (draw-particles)
+  (gl-bind-buffer (version-1-5 array-buffer) *vbo*)
+
+  (update-gl-buffer-data (version-1-5 array-buffer)
+                         *vertices*)
+
+  (gl-enable-client-state (enable-cap vertex-array))
+  (gl-enable-client-state (enable-cap color-array))
+  (set-gl-vertex-array (vertex-pointer-type float)
+                       #f
+                       #:stride (packed-struct-size color-vertex)
+                       #:offset (packed-struct-offset color-vertex x))
+  (set-gl-color-array (color-pointer-type float)
+                      #f
+                      #:stride (packed-struct-size color-vertex)
+                      #:offset (packed-struct-offset color-vertex r))
+  (gl-draw-arrays (begin-mode quads) 0
+                  (packed-array-length *vertices* color-vertex))
+  (gl-disable-client-state (enable-cap color-array))
+  (gl-disable-client-state (enable-cap vertex-array))
+
+  (gl-bind-buffer (version-1-5 array-buffer) 0))
+
+(define (update-quads)
+  (unpack-each
+   *particles*
+   particle
+   (lambda (n x y z vx vy vz)
+     (let ((r (/ (abs vx) 5))
+           (g (/ (abs vy) 5))
+           (b (/ (abs vz) 5))
+           (x- (- x 0.5))
+           (y- (- y 0.5))
+           (x+ (+ x 0.5))
+           (y+ (+ y 0.5))
+           (base (* n 4)))
+       (pack *vertices* base color-vertex
+             x- y- z
+             r g b)
+       (pack *vertices* (+ base 1) color-vertex
+             x+ y- z
+             r g b)
+       (pack *vertices* (+ base 2) color-vertex
+             x+ y+ z
+             r g b)
+       (pack *vertices* (+ base 3) color-vertex
+             x- y+ z
+             r g b)))))
+
+(define (update-particles dt)
+  (let ((half-dt-squared (* 0.5 dt dt)))
+    (repack-each
+     *particles*
+     particle
+     (lambda (n x y z vx vy vz)
+       (let* ((distance-squared (+ (* x x) (* y y) (* z z)))
+              (distance (sqrt distance-squared))
+              (F (/ -200 distance-squared))
+              (ax (* F (/ x distance)))
+              (ay (* F (/ y distance)))
+              (az (* F (/ z distance))))
+         (values (+ x (* vx dt) (* ax half-dt-squared))
+                 (+ y (* vy dt) (* ay half-dt-squared))
+                 (+ z (* vz dt) (* az half-dt-squared))
+                 (+ vx (* ax dt))
+                 (+ vy (* ay dt))
+                 (+ vz (* az dt))))))))
+
+(define (prepare-particles n)
+  (set! *particles* (make-packed-array particle n))
+  (set! *vertices* (make-packed-array color-vertex (* n 4)))
+
+  (pack-each
+   *particles*
+   particle
+   (lambda (n)
+     (values
+      ;; Position.
+      (* (random:normal) 30)
+      (* (random:normal) 30)
+      (* (random:normal) 30)
+
+      ;; Velocity.
+      (* (random:normal) 2)
+      (* (random:normal) 2)
+      (* (random:normal) 2))))
+
+  (update-quads)
+
+  (gl-delete-buffer *vbo*) ; no-op if 0
+  (set! *vbo* (gl-generate-buffer))
+
+  (gl-bind-buffer (version-1-5 array-buffer) *vbo*)
+  (set-gl-buffer-data (version-1-5 array-buffer)
+                      *vertices*
+                      (version-1-5 stream-draw))
+  (gl-bind-buffer (version-1-5 array-buffer) 0))
+
+(define main-window #f)
+
+(define (make-fps-accumulator period)
+  (let* ((frame-count 0)
+         (last-fps-time (get-internal-real-time))
+         (last-fps-run-time (get-internal-run-time))
+         (last-frame-time (get-internal-real-time))
+         (max-frame-time (get-internal-real-time))
+         (last-frame-count 0)
+         (jiffies-per-sec (exact->inexact internal-time-units-per-second))
+         (jiffies-per-ms (/ jiffies-per-sec 1000)))
+    (lambda ()
+      (let ((now (get-internal-real-time)))
+        (set! frame-count (1+ frame-count))
+        (when (> (- now last-frame-time) max-frame-time)
+          (set! max-frame-time (- now last-frame-time)))
+        (set! last-frame-time now)
+        (when (> (- now last-fps-time) period)
+          (let* ((run (get-internal-run-time))
+                 (frames (- frame-count last-frame-count))
+                 (secs (/ (- now last-fps-time) jiffies-per-sec))
+                 (fps (/ frames secs))
+                 (ms-per-frame (/ (* secs 1000) frames))
+                 (max-ms-per-frame (/ max-frame-time jiffies-per-ms))
+                 (cpu (* 100.0 (/ (- run last-fps-run-time)
+                                  (- now last-fps-time)))))
+            (format
+             (current-error-port)
+             ";;; ~a frames in ~,2f sec = ~,2f fps; ~,2f ms/frame, ~,2f ms max; ~,2f% CPU\n"
+             frames secs fps ms-per-frame max-ms-per-frame cpu)
+            (set! last-frame-count frame-count)
+            (set! max-frame-time 0)
+            (set! last-fps-time now)
+            (set! last-fps-run-time run)))))))
+
+(define accumulate-fps!
+  (make-fps-accumulator (* 2 internal-time-units-per-second)))
+
+(define (draw-axis scale)
+  ;; Could disable lighting and depth test.
+  (gl-begin (begin-mode lines)
+    (gl-color 1 0 0)
+    (gl-vertex 0 0 0)
+    (gl-vertex scale 0 0)
+
+    (gl-color 0 1 0)
+    (gl-vertex 0 0 0)
+    (gl-vertex 0 scale 0)
+        
+    (gl-color 0 0 1)
+    (gl-vertex 0 0 0)
+    (gl-vertex 0 0 scale)))
+
+(define (on-display)
+  (accumulate-fps!)
+  (gl-clear (clear-buffer-mask color-buffer depth-buffer))
+
+  (draw-axis 10)
+
+  (draw-particles)
+
+  ;; With double-buffering, swap-buffers will wait for the frame to be shown,
+  ;; which limits this program to the frame rate.
+  (swap-buffers))
+
+(define (on-reshape width height)
+  (pk 'reshape! width height)
+  (gl-viewport 0 0 width height)
+
+  ;; Projection matrix.
+  (set-gl-matrix-mode (matrix-mode projection))
+  (gl-load-identity)
+  (glu-perspective 60 (/ width height) 0.1 1000))
+
+(define full-screen? #f)
+(define running? #t)
+
+(define (on-keyboard keycode x y)
+  (let ((c (integer->char keycode)))
+    (case c
+      ((#\f)
+       (set! full-screen? (not full-screen?))
+       (full-screen main-window full-screen?))
+      ((#\esc #\etx #\q)
+       (format #t "~s pressed; quitting.\n" c)
+       (exit))
+      ((#\+)
+       ;; The rotations are a hack to re-orient so that a translation in the Z
+       ;; axis will move us towards the origin.
+       (gl-rotate -10 1 0 0)
+       (gl-translate 0 0 10)
+       (gl-rotate 10 1 0 0))
+      ((#\-)
+       (gl-rotate -10 1 0 0)
+       (gl-translate 0 0 -10)
+       (gl-rotate 10 1 0 0))
+      ((#\space)
+       (set! running? (not running?))
+       (set-idle-callback (and running? (lambda () (on-idle)))))
+      (else
+       (pk 'keyboard c x y)))))
+
+(define (on-special keycode x y)
+  (pk 'special keycode x y))
+
+(define (on-mouse button state x y)
+  (pk 'mouse button state x y))
+
+(define (on-motion x y)
+  (pk 'motion x y))
+
+(define (on-visibility visible?)
+  (pk 'visible visible?))
+
+(define (on-idle)
+  (set-gl-matrix-mode (matrix-mode modelview))
+  ;; Rotate the camera 0.05 degree per frame about the Z axis.  At 60 fps that's
+  ;; 120 seconds per full rotation.  Rotating about the Z axis keeps all the
+  ;; quads facing our way.
+  (gl-rotate 0.05 0 0 1)
+  (update-particles 0.016)
+  (update-quads)
+  (post-redisplay main-window))
+
+(define (register-glut-callbacks)
+  ;; The trampolines allow the handlers to be overridden at runtime by
+  ;; an attached Guile REPL client.
+  (set-display-callback (lambda () (on-display)))
+  (set-reshape-callback (lambda (w h) (on-reshape w h)))
+  (set-keyboard-callback (lambda (k x y) (on-keyboard k x y)))
+  (set-special-callback (lambda (k x y) (on-special k x y)))
+  (set-mouse-callback (lambda (b s x y) (on-mouse b s x y)))
+  (set-motion-callback (lambda (x y) (on-motion x y)))
+  (set-visibility-callback (lambda (visible?) (on-visibility visible?)))
+  (set-idle-callback (lambda () (on-idle))))
+
+(define (main args)
+  (let ((args
+         (initialize-glut args
+                          #:window-size '(640 . 480)
+                          #:display-mode (display-mode rgba alpha double
+                                                       depth))))
+    (set! main-window (make-window "particle-system"))
+    (register-glut-callbacks)
+    (set-gl-clear-color 0 0 0 1)
+    (set-gl-clear-depth 1)
+    #;
+    (set-gl-shade-model (shading-model smooth))
+
+    ;; Resetting the modelview matrix mode leaves the camera at the origin,
+    ;; oriented to look down the Z axis.  Rotate up a bit so that we can see the
+    ;; Z axis.
+    (set-gl-matrix-mode (matrix-mode modelview))
+    (gl-load-identity)
+    (gl-translate 0 0 -100)
+    (gl-rotate 10 1 0 0)
+
+    (gl-enable (enable-cap depth-test))
+
+    (set! *random-state* (random-state-from-platform))
+    (prepare-particles (match args
+                         ((_) 1000)
+                         ((_ n) (string->number n))))
+
+    (glut-main-loop)))
+
+(when (batch-mode?)
+  (exit (main (program-arguments))))