From: Javier Sancho <jsf@jsancho.org>
Date: Thu, 23 Jun 2016 00:07:19 +0000 (+0200)
Subject: Interface for guile-opengl and particle system example
X-Git-Url: https://git.jsancho.org/?p=gacela.git;a=commitdiff_plain;h=127ff76fc908625c94d4af63e8a4f62ef11ccc5c

Interface for guile-opengl and particle system example
---

diff --git a/examples/particle-system.scm b/examples/particle-system.scm
new file mode 100644
index 0000000..2b2c1b5
--- /dev/null
+++ b/examples/particle-system.scm
@@ -0,0 +1,179 @@
+#!/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))))
diff --git a/src/interfaces/opengl.scm b/src/interfaces/opengl.scm
new file mode 100644
index 0000000..b65015e
--- /dev/null
+++ b/src/interfaces/opengl.scm
@@ -0,0 +1,259 @@
+;;; 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/>.
+
+(define-module (gacela interfaces opengl)
+  #:use-module (glut)
+  #:use-module (gl)
+  #:use-module (glu)
+  #:use-module (glu low-level)
+  #:use-module (gl contrib packed-struct)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:export (for-each-event
+	    draw-quad
+	    draw-line
+	    make-game
+	    start-game
+	    translate-camera
+	    rotate-camera
+	    full-screen))
+
+
+;;; Events
+
+(define *input-events* '())
+
+(define (clean-input-events)
+  (set! *input-events* '()))
+
+(define (add-input-event event)
+  (set! *input-events*
+    (cons event *input-events*)))
+
+(define (on-keyboard keycode x y)
+  (add-input-event (list 'keyboard keycode x y)))
+
+(define (on-special keycode x y)
+  (add-input-event (list 'special keycode x y)))
+
+(define (on-mouse button state x y)
+    (add-input-event (list 'mouse button state x y)))
+
+(define (on-motion x y)
+    (add-input-event (list 'motion x y)))
+
+(define (on-visibility visible?)
+    (add-input-event (list 'visible visible?)))
+
+(define* (for-each-event proc)
+  (let loop ((events *input-events*))
+    (cond ((not (null? events))
+	   (proc (car events))
+	   (loop (cdr events))))))
+
+
+;;; Display
+
+(define-packed-struct color-vertex
+  (x float)
+  (y float)
+  (z float)
+
+  (r float)
+  (g float)
+  (b float))
+
+(define *vertices-list* '())
+(define *lines-list* '())
+
+(define (on-reshape width height)
+  (pk 'reshape! width height)
+  (gl-viewport 0 0 width height)
+
+  ;; Projection matrix.
+  (set-gl-matrix-mode (matrix-mode projection))
+  (gl-load-identity)
+  (glu-perspective 60 (/ width height) 0.1 1000))
+
+(define (draw-vertices mode array)
+  (gl-enable-client-state (enable-cap vertex-array))
+  (gl-enable-client-state (enable-cap color-array))
+  (set-gl-vertex-array (vertex-pointer-type float)
+		       array
+		       #:stride (packed-struct-size color-vertex)
+		       #:offset (packed-struct-offset color-vertex x))
+  (set-gl-color-array (color-pointer-type float)
+		      array
+		      #:stride (packed-struct-size color-vertex)
+		      #:offset (packed-struct-offset color-vertex r))
+  (gl-draw-arrays mode 0
+		  (packed-array-length array color-vertex))
+  (gl-disable-client-state (enable-cap color-array))
+  (gl-disable-client-state (enable-cap vertex-array)))
+
+(define *display-hook* (lambda () #f))
+
+(define (on-display)
+  (*display-hook*)
+  (gl-clear (clear-buffer-mask color-buffer depth-buffer))
+  (draw-vertices (begin-mode quads) (prepare-array *vertices-list*))
+  (draw-vertices (begin-mode lines) (prepare-array *lines-list*))
+  (swap-buffers))
+
+(define* (draw-quad pos #:key (color '(1 1 1)) (size 1))
+  (let* ((x (car pos))
+	 (y (cadr pos))
+	 (z (caddr pos))
+	 (delta (/ size 2.0))
+	 (x- (- x delta))
+	 (y- (- y delta))
+	 (x+ (+ x delta))
+	 (y+ (+ y delta))
+	 (r (car color))
+	 (g (cadr color))
+	 (b (caddr color)))
+    (set! *vertices-list*
+      (append
+       (list
+	(list x- y- z r g b)
+	(list x+ y- z r g b)
+	(list x+ y+ z r g b)
+	(list x- y+ z r g b))
+       *vertices-list*))))
+
+(define* (draw-line pos1 pos2 #:key (color '(1 1 1)))
+  (let* ((x1 (car pos1))
+	 (y1 (cadr pos1))
+	 (z1 (caddr pos1))
+	 (x2 (car pos2))
+	 (y2 (cadr pos2))
+	 (z2 (caddr pos2))
+	 (r (car color))
+	 (g (cadr color))
+	 (b (caddr color)))
+    (set! *lines-list*
+      (append
+       (list
+	(list x1 y1 z1 r g b)
+	(list x2 y2 z2 r g b))
+       *lines-list*))))
+
+(define (add-vertex array base type vertex)
+  (let ((pos vertex)
+	(color (cdddr vertex)))
+    (pack array base type
+	  (car pos) (cadr pos) (caddr pos)
+	  (car color) (cadr color) (caddr color))))
+
+(define (prepare-array vertices)
+  (let loop ((array (make-packed-array color-vertex (length vertices)))
+	     (base 0)
+	     (vertices vertices))
+    (cond ((null? vertices)
+	   array)
+	  (else
+	   (let ((vertex (car vertices)))
+	     (add-vertex array base color-vertex vertex))
+	   (loop array (+ base 1) (cdr vertices))))))
+
+
+;;; Loop
+
+(define *now* (get-internal-real-time))
+(define *loops* 0)
+(define *main-loop-hook* (lambda () #f))
+(define main-window #f)
+
+(define (on-idle)
+  (cond ((and (> (get-internal-real-time) *now*) (> 10 *loops*))
+	 (set-gl-matrix-mode (matrix-mode modelview))
+	 (set! *vertices-list* '())
+	 (*main-loop-hook*)
+	 (clean-input-events)
+	 (set! *now* (+ *now* 20))
+	 (set! *loops* (+ *loops* 1)))
+	(else
+	 (post-redisplay main-window)
+	 (set! *loops* 0))))
+
+(define (full-screen full-screen?)
+  ((@ (glut) full-screen) main-window full-screen?))
+
+
+;;; Game
+
+(define-record-type game
+  (make-game-record name)
+  game?
+  (name get-name set-name!))
+
+(set-record-type-printer! game
+  (lambda (record port)
+    (format port "#<[game] ~a>" (get-name record))))
+
+(define (register-glut-callbacks)
+  ;; The trampolines allow the handlers to be overridden at runtime by
+  ;; an attached Guile REPL client.
+  (set-display-callback (lambda () (on-display)))
+  (set-reshape-callback (lambda (w h) (on-reshape w h)))
+  (set-keyboard-callback (lambda (k x y) (on-keyboard k x y)))
+  (set-special-callback (lambda (k x y) (on-special k x y)))
+  (set-mouse-callback (lambda (b s x y) (on-mouse b s x y)))
+  (set-motion-callback (lambda (x y) (on-motion x y)))
+  (set-visibility-callback (lambda (visible?) (on-visibility visible?)))
+  (set-idle-callback (lambda () (on-idle))))
+
+(define* (make-game name
+		    #:key
+		    (window-size '(50 . 50))
+		    (display-mode (display-mode rgba alpha double depth))
+		    (bg-color '(0 0 0 1))
+		    (depth 1)
+		    (shading-model (shading-model smooth))
+		    (main-loop-hook (lambda () #f))
+		    (display-hook (lambda () #f)))
+
+  (initialize-glut #:window-size window-size
+		   #:display-mode display-mode)
+
+  (set! main-window (make-window name))
+  (register-glut-callbacks)
+  (apply set-gl-clear-color bg-color)
+  (set-gl-clear-depth depth)
+  (set-gl-shade-model shading-model)
+
+  (set-gl-matrix-mode (matrix-mode modelview))
+  (gl-load-identity)
+
+  (gl-enable (enable-cap depth-test))
+
+  (set! *main-loop-hook* main-loop-hook)
+  (set! *display-hook* display-hook)
+
+  (make-game-record name))
+
+(define (start-game game)
+  (glut-main-loop))
+
+
+;;; Camera
+
+(define (translate-camera x y z)
+  (gl-translate x y z))
+
+(define (rotate-camera angle x y z)
+  (gl-rotate angle x y z))