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