5 ;;; Copyright (C) 2014 Free Software Foundation, Inc.
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.
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.
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/>.
21 (use-modules (gacela interfaces opengl)
25 (define *particles* '())
27 (define (draw-particles particles)
32 (let ((r (/ (abs vx) 5))
39 (draw-quad (list x y z) #:color (list r g b))))))
42 (define (update-particles dt)
43 (let ((half-dt-squared (* 0.5 dt dt)))
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))
63 (define (prepare-particles n)
70 (* (random:normal) 30)
71 (* (random:normal) 30)
72 (* (random:normal) 30)
77 (* (random:normal) 2))
78 (prepare-particles (- n 1))))))
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))
87 (jiffies-per-sec (exact->inexact internal-time-units-per-second))
88 (jiffies-per-ms (/ jiffies-per-sec 1000)))
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))
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)))))
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)))))))
113 (define accumulate-fps!
114 (make-fps-accumulator (* 2 internal-time-units-per-second)))
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)))
121 (define full-screen? #f)
124 (define (handle-events)
127 (let ((event-type (car event)))
130 (let ((c (integer->char (cadr event))))
133 (set! full-screen? (not full-screen?))
134 (full-screen full-screen?))
136 (format #t "~s pressed; quitting.\n" c)
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))
145 (rotate-camera -10 1 0 0)
146 (translate-camera 0 0 -10)
147 (rotate-camera 10 1 0 0))
149 (set! running? (not running?)))
158 (rotate-camera 0.05 0 0 1)
159 (update-particles 0.016)))
161 (draw-particles *particles*))
164 (set! *random-state* (random-state-from-platform))
166 (prepare-particles (match args
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)
179 (exit (main (program-arguments))))