From: Javier Sancho 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/?a=commitdiff_plain;h=127ff76fc908625c94d4af63e8a4f62ef11ccc5c;p=gacela.git 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 +;;; . + +(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 +;;; . + +(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))