examples/particle-system.scm

   1 #!/usr/bin/env guile
   2 !#
   3
   4 ;;; Guile-OpenGL
   5 ;;; Copyright (C) 2014 Free Software Foundation, Inc.
   6 ;;;
   7 ;;; Guile-OpenGL is free software: you can redistribute it and/or modify
   8 ;;; it 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 ;;; Guile-OpenGL is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 ;;; Lesser General 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 (gacela interfaces opengl)
  22              (ice-9 format)
  23              (ice-9 match))
  24
  25 (define *particles* '())
  26
  27 (define (draw-particles particles)
  28   (for-each
  29    (lambda (particle)
  30      (match particle
  31        ((x y z vx vy vz)
  32         (let ((r (/ (abs vx) 5))
  33               (g (/ (abs vy) 5))
  34               (b (/ (abs vz) 5))
  35               (x- (- x 0.5))
  36               (y- (- y 0.5))
  37               (x+ (+ x 0.5))
  38               (y+ (+ y 0.5)))
  39           (draw-quad (list x y z) #:color (list r g b))))))
  40    particles))
  41
  42 (define (update-particles dt)
  43   (let ((half-dt-squared (* 0.5 dt dt)))
  44     (set! *particles*
  45       (map
  46        (lambda (particle)
  47          (match particle
  48            ((x y z vx vy vz)
  49             (let* ((distance-squared (+ (* x x) (* y y) (* z z)))
  50                    (distance (sqrt distance-squared))
  51                    (F (/ -200 distance-squared))
  52                    (ax (* F (/ x distance)))
  53                    (ay (* F (/ y distance)))
  54                    (az (* F (/ z distance))))
  55               (list (+ x (* vx dt) (* ax half-dt-squared))
  56                     (+ y (* vy dt) (* ay half-dt-squared))
  57                     (+ z (* vz dt) (* az half-dt-squared))
  58                     (+ vx (* ax dt))
  59                     (+ vy (* ay dt))
  60                     (+ vz (* az dt)))))))
  61        *particles*))))
  62
  63 (define (prepare-particles n)
  64   (cond ((= n 0)
  65          '())
  66         (else
  67          (cons
  68           (list
  69            ;; Position.
  70            (* (random:normal) 30)
  71            (* (random:normal) 30)
  72            (* (random:normal) 30)
  73
  74            ;; Velocity.
  75            (* (random:normal) 2)
  76            (* (random:normal) 2)
  77            (* (random:normal) 2))
  78           (prepare-particles (- n 1))))))
  79
  80 (define (make-fps-accumulator period)
  81   (let* ((frame-count 0)
  82          (last-fps-time (get-internal-real-time))
  83          (last-fps-run-time (get-internal-run-time))
  84          (last-frame-time (get-internal-real-time))
  85          (max-frame-time (get-internal-real-time))
  86          (last-frame-count 0)
  87          (jiffies-per-sec (exact->inexact internal-time-units-per-second))
  88          (jiffies-per-ms (/ jiffies-per-sec 1000)))
  89     (lambda ()
  90       (let ((now (get-internal-real-time)))
  91         (set! frame-count (1+ frame-count))
  92         (when (> (- now last-frame-time) max-frame-time)
  93           (set! max-frame-time (- now last-frame-time)))
  94         (set! last-frame-time now)
  95         (when (> (- now last-fps-time) period)
  96           (let* ((run (get-internal-run-time))
  97                  (frames (- frame-count last-frame-count))
  98                  (secs (/ (- now last-fps-time) jiffies-per-sec))
  99                  (fps (/ frames secs))
 100                  (ms-per-frame (/ (* secs 1000) frames))
 101                  (max-ms-per-frame (/ max-frame-time jiffies-per-ms))
 102                  (cpu (* 100.0 (/ (- run last-fps-run-time)
 103                                   (- now last-fps-time)))))
 104             (format
 105              (current-error-port)
 106              ";;; ~a frames in ~,2f sec = ~,2f fps; ~,2f ms/frame, ~,2f ms max; ~,2f% CPU\n"
 107              frames secs fps ms-per-frame max-ms-per-frame cpu)
 108             (set! last-frame-count frame-count)
 109             (set! max-frame-time 0)
 110             (set! last-fps-time now)
 111             (set! last-fps-run-time run)))))))
 112
 113 (define accumulate-fps!
 114   (make-fps-accumulator (* 2 internal-time-units-per-second)))
 115
 116 (define (draw-axis scale)
 117   (draw-line '(0 0 0) (list scale 0 0) #:color '(1 0 0))
 118   (draw-line '(0 0 0) (list 0 scale  0) #:color '(0 1 0))
 119   (draw-line '(0 0 0) (list 0 0 scale) #:color '(0 0 1)))
 120
 121 (define full-screen? #f)
 122 (define running? #t)
 123
 124 (define (handle-events)
 125   (for-each-event
 126    (lambda (event)
 127      (let ((event-type (car event)))
 128        (case event-type
 129          ((keyboard)
 130           (let ((c (integer->char (cadr event))))
 131             (case c
 132               ((#\f)
 133                (set! full-screen? (not full-screen?))
 134                (full-screen full-screen?))
 135               ((#\esc #\etx #\q)
 136                (format #t "~s pressed; quitting.\n" c)
 137                (exit))
 138               ((#\+)
 139                ;; The rotations are a hack to re-orient so that a translation in the Z
 140                ;; axis will move us towards the origin.
 141                (rotate-camera -10 1 0 0)
 142                (translate-camera 0 0 10)
 143                (rotate-camera 10 1 0 0))
 144               ((#\-)
 145                (rotate-camera -10 1 0 0)
 146                (translate-camera 0 0 -10)
 147                (rotate-camera 10 1 0 0))
 148               ((#\space)
 149                (set! running? (not running?)))
 150               (else
 151                (pk event)))))
 152          (else
 153           (pk event)))))))
 154
 155 (define (game-logic)
 156   (handle-events)
 157   (cond (running?
 158          (rotate-camera 0.05 0 0 1)
 159          (update-particles 0.016)))
 160   (draw-axis 10)
 161   (draw-particles *particles*))
 162
 163 (define (main args)
 164   (set! *random-state* (random-state-from-platform))
 165   (set! *particles*
 166     (prepare-particles (match args
 167                          ((_) 1000)
 168                          ((_ n) (string->number n)))))
 169   (draw-particles *particles*)
 170   (let ((game (make-game "particle-system"
 171                          #:window-size '(640 . 480)
 172                          #:main-loop-hook game-logic
 173                          #:display-hook accumulate-fps!)))
 174     (translate-camera 0 0 -100)
 175     (rotate-camera 10 1 0 0)
 176     (start-game game)))
 177
 178 (when (batch-mode?)
 179   (exit (main (program-arguments))))