examples/particle-system/vbo.scm

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