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