--- /dev/null
+#!/usr/bin/env guile
+!#
+
+;;; Guile-OpenGL
+;;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;;
+;;; Guile-OpenGL is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; Guile-OpenGL is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(use-modules (gacela interfaces opengl)
+ (ice-9 format)
+ (ice-9 match))
+
+(define *particles* '())
+
+(define (draw-particles particles)
+ (for-each
+ (lambda (particle)
+ (match particle
+ ((x y z vx vy vz)
+ (let ((r (/ (abs vx) 5))
+ (g (/ (abs vy) 5))
+ (b (/ (abs vz) 5))
+ (x- (- x 0.5))
+ (y- (- y 0.5))
+ (x+ (+ x 0.5))
+ (y+ (+ y 0.5)))
+ (draw-quad (list x y z) #:color (list r g b))))))
+ particles))
+
+(define (update-particles dt)
+ (let ((half-dt-squared (* 0.5 dt dt)))
+ (set! *particles*
+ (map
+ (lambda (particle)
+ (match particle
+ ((x y z vx vy vz)
+ (let* ((distance-squared (+ (* x x) (* y y) (* z z)))
+ (distance (sqrt distance-squared))
+ (F (/ -200 distance-squared))
+ (ax (* F (/ x distance)))
+ (ay (* F (/ y distance)))
+ (az (* F (/ z distance))))
+ (list (+ x (* vx dt) (* ax half-dt-squared))
+ (+ y (* vy dt) (* ay half-dt-squared))
+ (+ z (* vz dt) (* az half-dt-squared))
+ (+ vx (* ax dt))
+ (+ vy (* ay dt))
+ (+ vz (* az dt)))))))
+ *particles*))))
+
+(define (prepare-particles n)
+ (cond ((= n 0)
+ '())
+ (else
+ (cons
+ (list
+ ;; Position.
+ (* (random:normal) 30)
+ (* (random:normal) 30)
+ (* (random:normal) 30)
+
+ ;; Velocity.
+ (* (random:normal) 2)
+ (* (random:normal) 2)
+ (* (random:normal) 2))
+ (prepare-particles (- n 1))))))
+
+(define (make-fps-accumulator period)
+ (let* ((frame-count 0)
+ (last-fps-time (get-internal-real-time))
+ (last-fps-run-time (get-internal-run-time))
+ (last-frame-time (get-internal-real-time))
+ (max-frame-time (get-internal-real-time))
+ (last-frame-count 0)
+ (jiffies-per-sec (exact->inexact internal-time-units-per-second))
+ (jiffies-per-ms (/ jiffies-per-sec 1000)))
+ (lambda ()
+ (let ((now (get-internal-real-time)))
+ (set! frame-count (1+ frame-count))
+ (when (> (- now last-frame-time) max-frame-time)
+ (set! max-frame-time (- now last-frame-time)))
+ (set! last-frame-time now)
+ (when (> (- now last-fps-time) period)
+ (let* ((run (get-internal-run-time))
+ (frames (- frame-count last-frame-count))
+ (secs (/ (- now last-fps-time) jiffies-per-sec))
+ (fps (/ frames secs))
+ (ms-per-frame (/ (* secs 1000) frames))
+ (max-ms-per-frame (/ max-frame-time jiffies-per-ms))
+ (cpu (* 100.0 (/ (- run last-fps-run-time)
+ (- now last-fps-time)))))
+ (format
+ (current-error-port)
+ ";;; ~a frames in ~,2f sec = ~,2f fps; ~,2f ms/frame, ~,2f ms max; ~,2f% CPU\n"
+ frames secs fps ms-per-frame max-ms-per-frame cpu)
+ (set! last-frame-count frame-count)
+ (set! max-frame-time 0)
+ (set! last-fps-time now)
+ (set! last-fps-run-time run)))))))
+
+(define accumulate-fps!
+ (make-fps-accumulator (* 2 internal-time-units-per-second)))
+
+(define (draw-axis scale)
+ (draw-line '(0 0 0) (list scale 0 0) #:color '(1 0 0))
+ (draw-line '(0 0 0) (list 0 scale 0) #:color '(0 1 0))
+ (draw-line '(0 0 0) (list 0 0 scale) #:color '(0 0 1)))
+
+(define full-screen? #f)
+(define running? #t)
+
+(define (handle-events)
+ (for-each-event
+ (lambda (event)
+ (let ((event-type (car event)))
+ (case event-type
+ ((keyboard)
+ (let ((c (integer->char (cadr event))))
+ (case c
+ ((#\f)
+ (set! full-screen? (not full-screen?))
+ (full-screen full-screen?))
+ ((#\esc #\etx #\q)
+ (format #t "~s pressed; quitting.\n" c)
+ (exit))
+ ((#\+)
+ ;; The rotations are a hack to re-orient so that a translation in the Z
+ ;; axis will move us towards the origin.
+ (rotate-camera -10 1 0 0)
+ (translate-camera 0 0 10)
+ (rotate-camera 10 1 0 0))
+ ((#\-)
+ (rotate-camera -10 1 0 0)
+ (translate-camera 0 0 -10)
+ (rotate-camera 10 1 0 0))
+ ((#\space)
+ (set! running? (not running?)))
+ (else
+ (pk event)))))
+ (else
+ (pk event)))))))
+
+(define (game-logic)
+ (handle-events)
+ (cond (running?
+ (rotate-camera 0.05 0 0 1)
+ (update-particles 0.016)))
+ (draw-axis 10)
+ (draw-particles *particles*))
+
+(define (main args)
+ (set! *random-state* (random-state-from-platform))
+ (set! *particles*
+ (prepare-particles (match args
+ ((_) 1000)
+ ((_ n) (string->number n)))))
+ (draw-particles *particles*)
+ (let ((game (make-game "particle-system"
+ #:window-size '(640 . 480)
+ #:main-loop-hook game-logic
+ #:display-hook accumulate-fps!)))
+ (translate-camera 0 0 -100)
+ (rotate-camera 10 1 0 0)
+ (start-game game)))
+
+(when (batch-mode?)
+ (exit (main (program-arguments))))
projects / gacela.git / blobdiff