;;;
;;; ogl2brick - OpenGL shading language demo
;;;
;;; This is a pretty straightforward port of the C code provided
;;; by 3DLabs Inc under the BSD-license. The original copyright
;;; notice follows.
;;;
#|
/************************************************************************
* *
* Copyright (C) 2002-2004 3Dlabs Inc. Ltd. *
* *
* All rights reserved. *
* *
* Redistribution and use in source and binary forms, with or without *
* modification, are permitted provided that the following conditions *
* are met: *
* *
* Redistributions of source code must retain the above copyright *
* notice, this list of conditions and the following disclaimer. *
* *
* Redistributions in binary form must reproduce the above *
* copyright notice, this list of conditions and the following *
* disclaimer in the documentation and/or other materials provided *
* with the distribution. *
* *
* Neither the name of the 3Dlabs nor the names of its *
* contributors may be used to endorse or promote products derived *
* from this software without specific prior written permission. *
* *
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *
* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *
* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *
* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *
* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *
* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *
* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; *
* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER *
* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT *
* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *
* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *
* POSSIBILITY OF SUCH DAMAGE. *
* *
/************************************************************************/
|#
;;; $Id: ogl2particle.scm,v 1.4 2005-06-10 11:27:17 shirok Exp $
(use srfi-1)
(use srfi-27)
(use gauche.uvector)
(use gl)
(use gl.glut)
(use file.util)
(use math.const)
;; flags for doing animation
(define *particle-time* 0.0)
(define *program-object* #f)
;; Movement variables
(define *fxdiff* 206.0)
(define *fydiff* 16.0)
(define *fzdiff* 10.0)
(define *xlastincr* 0)
(define *ylastincr* 0)
(define *fxinertia* -0.5)
(define *fyinertia* 0)
(define *fxinertiaold* 0)
(define *fyinertiaold* 0)
(define *fscale* 0.25)
(define *ftime* 0)
(define *xlast* -1)
(define *ylast* -1)
(define *modifiers* 0)
(define *rotate* #t)
;; rotation defines
(define-constant INERTIA_THRESHOLD 1.0)
(define-constant INERTIA_FACTOR 0.5)
(define-constant SCALE_FACTOR 0.01)
(define-constant SCALE_INCREMENT 0.5)
(define-constant TIMER_FREQUENCY_MILLIS 20)
;; extra uniform arrays
(define-constant VELOCITY_ARRAY 4)
(define-constant START_TIME_ARRAY 5)
(define (print-opengl-error)
(let loop ((err (gl-get-error))
(status 0))
(if (= err GL_NO_ERROR)
status
(begin
(format "glError: ~s~%" (glu-error-string err))
(loop (gl-get-error) 1)))))
(define next-clear-color
(let1 color 0
(lambda ()
(case (modulo color 3)
((0) (gl-clear-color 0.0 0.0 0.0 1.0))
((1) (gl-clear-color 0.2 0.2 0.3 1.0))
((2) (gl-clear-color 0.7 0.7 0.7 1.0)))
(inc! color))))
;;
;; GLUT glue
;;
(define (display-proc)
(gl-load-identity)
(gl-translate 0.0 0.0 -5.0)
(gl-rotate *fydiff* 1 0 0)
(gl-rotate *fxdiff* 0 1 0)
(gl-rotate *fzdiff* 0 0 1)
(gl-scale *fscale* *fscale* *fscale*)
(gl-clear (logior GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
(draw-points)
(gl-flush)
(glut-swap-buffers)
)
(define (update-anim)
(let1 location (get-uniloc *program-object* "Time")
(inc! *particle-time* 0.002)
(when (> *particle-time* 15.0)
(set! *particle-time* 0.0))
(gl-uniform1-arb location *particle-time*)
(print-opengl-error)))
(define (play-proc)
(let1 thistime (glut-get GLUT_ELAPSED_TIME)
(update-anim)
(print-opengl-error)
(glut-post-redisplay)
(print-opengl-error)))
(define (key-proc key x y)
(set! *particle-time* 0)
(cond
((eqv? key (char->integer #\b))
(next-clear-color))
((eqv? key (char->integer #\q))
(exit))
((eqv? key (char->integer #\space))
(set! *rotate* (not *rotate*))
(if (not *rotate*)
(begin
(set! *fxinertiaold* *fxinertia*)
(set! *fyinertiaold* *fyinertia*))
(begin
(set! *fxinertia* *fxinertiaold*)
(set! *fyinertia* *fyinertiaold*)
;; To prevent confusion, force some rotation
(when (and (zero? *fxinertia*) (zero? *fyinertia*))
(set! *fxinertia* -0.5)))))
((eqv? key (char->integer #\+))
(inc! *fscale* SCALE_INCREMENT))
((eqv? key (char->integer #\-))
(dec! *fscale* SCALE_INCREMENT))
(else
(print "Keyboard commands:\n")
(print "b - Toggle among background clear colors")
(print "q - Quit")
(print "? - Help")
(print "<home> - reset zoom and rotation")
(print "<space> or <click> - stop rotation")
(print "<+>, <-> or <ctrl + drag> - zoom model")
(print "<arrow keys> or <drag> - rotate model"))
))
(define (timer-proc value)
(inc! *ftime* 0.01)
(when *rotate*
(inc! *fxdiff* *fxinertia*)
(inc! *fydiff* *fyinertia*))
(glut-timer-func TIMER_FREQUENCY_MILLIS timer-proc 0))
(define (mouse-proc button state x y)
(set! *modifiers* (glut-get-modifiers))
(when (= button GLUT_LEFT_BUTTON)
(if (= state GLUT_UP)
(begin
(set! *xlast* -1)
(set! *ylast* -1)
(when (> *xlastincr* INERTIA_THRESHOLD)
(set! *fxinertia*
(* (- *xlastincr* INERTIA_THRESHOLD) INERTIA_FACTOR)))
(when (> (- *xlastincr*) INERTIA_THRESHOLD)
(set! *fxinertia*
(* (+ *xlastincr* INERTIA_THRESHOLD) INERTIA_FACTOR)))
(when (> *ylastincr* INERTIA_THRESHOLD)
(set! *fyinertia*
(* (- *ylastincr* INERTIA_THRESHOLD) INERTIA_FACTOR)))
(when (> (- *ylastincr*) INERTIA_THRESHOLD)
(set! *fyinertia*
(* (+ *ylastincr* INERTIA_THRESHOLD) INERTIA_FACTOR)))
)
(begin
(set! *fxinertia* 0)
(set! *fyinertia* 0)))
(set! *xlastincr* 0)
(set! *ylastincr* 0))
)
(define (motion-proc x y)
(unless (and (= *xlast* -1) (= *ylast* -1))
(set! *xlastincr* (- x *xlast*))
(set! *ylastincr* (- y *ylast*))
(if (logand *modifiers* GLUT_ACTIVE_CTRL)
(unless (= *xlast* -1)
(inc! *fzdiff* *xlastincr*)
(inc! *fscale* (* *ylastincr* SCALE_FACTOR)))
(unless (= *xlast* -1)
(inc! *fxdiff* *xlastincr*)
(inc! *fydiff* *ylastincr*))))
(set! *xlast* x)
(set! *ylast* y))
(define (reshape-proc w h)
(let ((vp 0.8)
(aspect (/ w h)))
(gl-viewport 0 0 w h)
(gl-matrix-mode GL_PROJECTION)
(gl-load-identity)
(gl-frustum (- vp) vp (/ (- vp) aspect) (/ vp aspect) 3 10.0)
(gl-matrix-mode GL_MODELVIEW)
(gl-load-identity)
(gl-translate 0.0 0.0 -5.0)))
(define (special-proc key x y)
(cond
((= key GLUT_KEY_HOME)
(set! *fxdiff* 0)
(set! *fydiff* 35)
(set! *fzdiff* 0)
(set! *xlastincr* 0)
(set! *ylastincr* 0)
(set! *fxinertia* -0.5)
(set! *fyinertia* 0)
(set! *fscale* 1.0))
((= key GLUT_KEY_LEFT)
(dec! *fxdiff*))
((= key GLUT_KEY_RIGHT)
(inc! *fxdiff*))
((= key GLUT_KEY_UP)
(dec! *fydiff*))
((= key GLUT_KEY_DOWN)
(inc! *fydiff*))
))
;;;
;;; create-points and draw-points (original source is draw.c)
;;;
(define-values
(create-points draw-points)
(let ((array-width #f)
(array-height #f)
(verts #f)
(colors #f)
(velocities #f)
(start-times #f))
(define (create-points w h)
(set! verts (make-f32vector (* w h 3)))
(set! colors (make-f32vector (* w h 3)))
(set! velocities (make-f32vector (* w h 3)))
(set! start-times (make-f32vector (* w h)))
(do ((i (- (/ 0.5 w) 0.5) (+ i (/ w)))
(n 0 (+ n 3))
(m 0 (+ m 1)))
((>= i 0.5))
(do ((j (- (/ 0.5 h) 0.5) (+ j (/ h)))
(n n (+ n 3))
(m m (+ m 1)))
((>= j 0.5))
(set! (ref verts n) i)
(set! (ref verts (+ n 1)) 0.0)
(set! (ref verts (+ n 2)) j)
(set! (ref colors n) (/ (+ (random-real) 1) 2))
(set! (ref colors (+ n 1)) (/ (+ (random-real) 1) 2))
(set! (ref colors (+ n 2)) (/ (+ (random-real) 1) 2))
(set! (ref velocities n) (+ (random-real) 3.0))
(set! (ref velocities (+ n 1)) (* (random-real) 10.0))
(set! (ref velocities (+ n 2)) (+ (random-real) 3.0))
(set! (ref start-times m) (* (random-real) 10.0))
)
)
(set! array-width w)
(set! array-height h))
(define (draw-points)
(gl-point-size 2.0)
(gl-vertex-pointer 3 verts)
(gl-color-pointer 3 colors)
(gl-vertex-attrib-pointer-arb VELOCITY_ARRAY 3 velocities)
(gl-vertex-attrib-pointer-arb START_TIME_ARRAY 1 start-times)
(gl-enable-client-state GL_VERTEX_ARRAY)
(gl-enable-client-state GL_COLOR_ARRAY)
(gl-enable-vertex-attrib-array-arb VELOCITY_ARRAY)
(gl-enable-vertex-attrib-array-arb START_TIME_ARRAY)
(gl-draw-arrays GL_POINTS 0 (* array-width array-height))
(gl-disable-client-state GL_VERTEX_ARRAY)
(gl-disable-client-state GL_COLOR_ARRAY)
(gl-disable-vertex-attrib-array-arb VELOCITY_ARRAY)
(gl-disable-vertex-attrib-array-arb START_TIME_ARRAY)
)
(values create-points draw-points)))
;;;
;;; shader-stuff (original source in shader.c)
;;;
(define (get-uniloc program name)
(let1 loc (gl-get-uniform-location-arb program name)
(when (negative? loc)
(error "No such uniform:" name))
(print-opengl-error)
loc))
(define (print-info-log obj)
(print-opengl-error)
(format #t "InfoLog:\n~a\n\n" (gl-get-info-log-arb obj))
(print-opengl-error))
(define (install-particle-shaders vsh fsh)
;; Create a vertex shader object and a fragment shader object
(let* ((vs (gl-create-shader-object-arb GL_VERTEX_SHADER_ARB))
(fs (gl-create-shader-object-arb GL_FRAGMENT_SHADER_ARB))
(vert-compiled 1)
(frag-compiled 1)
(linked #f))
;; Load source code strings into shaders
(gl-shader-source-arb vs (list vsh))
(gl-shader-source-arb fs (list fsh))
;; Compile the brick vertex shader, and print out
;; the compiler log file.
(gl-compile-shader-arb vs)
(print-opengl-error) ;; Check for OpenGL errors
(set! vert-compiled
(gl-get-object-parameter-arb vs GL_OBJECT_COMPILE_STATUS_ARB))
(print-info-log vs)
;; Compile the brick fragment shader, and print out
;; the compiler log file.
(gl-compile-shader-arb fs)
(print-opengl-error)
(set! frag-compiled
(gl-get-object-parameter-arb fs GL_OBJECT_COMPILE_STATUS_ARB))
(print-info-log fs)
(if (or (zero? vert-compiled) (zero? frag-compiled))
#f ;; failure
;; Create a program object and attach the two compiled shaders
(let1 progobj (gl-create-program-object-arb)
(set! *program-object* progobj)
(gl-attach-object-arb progobj vs)
(gl-attach-object-arb progobj fs)
;; Bind generic attribute indices
(gl-bind-attrib-location-arb progobj VELOCITY_ARRAY "Velocity")
(gl-bind-attrib-location-arb progobj START_TIME_ARRAY "StartTime")
;; Link the program object and print out the info log
(gl-link-program-arb progobj)
(print-opengl-error)
(set! linked
(gl-get-object-parameter-arb progobj GL_OBJECT_LINK_STATUS_ARB))
(print-info-log progobj)
(if (zero? linked)
#f ;; failure
(begin
;; Install program object as part of current state
(gl-use-program-object-arb progobj)
(gl-uniform4-arb (get-uniloc progobj "Background")
0.0 0.0 0.0 1.0)
(print-opengl-error)
(gl-uniform1-arb (get-uniloc progobj "Time") -5.0)
(print-opengl-error)
#t ;; success
))
)))
)
;;;
;;; main
;;;
(define (main args)
(glut-init args)
(glut-init-display-mode (logior GLUT_RGB GLUT_DEPTH GLUT_DOUBLE))
(glut-init-window-size 500 500)
(let* ((window (glut-create-window
"3Dlabs OpenGL Shading Language Particle System Demo")))
(unless (gl-extension-available? 'GL_ARB_shader_objects
'GL_ARB_fragment_shader
'GL_ARB_vertex_shader
'GL_ARB_shading_language_100)
(error "OpenGL Shading Language extensions not available"))
(glut-idle-func play-proc)
(glut-display-func display-proc)
(glut-keyboard-func key-proc)
(glut-reshape-func reshape-proc)
(glut-motion-func motion-proc)
(glut-mouse-func mouse-proc)
(glut-special-func special-proc)
(glut-timer-func TIMER_FREQUENCY_MILLIS timer-proc 0)
(create-points 100 100)
(gl-depth-func GL_LESS)
(gl-enable GL_DEPTH_TEST)
(next-clear-color)
(key-proc (char->integer #\?) 0 0) ;; display help
(let ((vs (file->string "particle.vert"))
(fs (file->string "particle.frag")))
(and (install-particle-shaders vs fs)
(glut-main-loop)))
0))
