]> git.jsancho.org Git - gacela.git/blob - examples/particle-system.scm
Environment for execution without previous installation
[gacela.git] / 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))))