examples/particle-system/client-arrays.scm

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