;;; ;;; 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: ogl2brick.scm,v 1.4 2005/06/10 11:27:16 shirok Exp $ (use srfi-1) (use gauche.uvector) (use gl) (use gl.glut) (use math.const) (use util.match) (use file.util) ;; Movement variables (define *fxdiff* 206) (define *fydiff* 16) (define *fzdiff* 10) (define *xlastincr* 0) (define *ylastincr* 0) (define *fxinertia* -0.5) (define *fyinertia* 0) (define *fxinertiaold* 0) (define *fyinertiaold* 0) (define *fscale* 1.0) (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) (define *rotl* pi/180) (define *lasttime* 0) (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)))) ;; Models to render ;; a circular list of thunks (define *models* (circular-list (lambda () (glut-solid-teapot 0.6)) (lambda () (glut-solid-torus 0.2 0.6 64 64)) (lambda () (glut-solid-sphere 0.6 64 64)) (lambda () (draw-cube)))) ;;; ;;; 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)) ((car *models*)) (gl-flush) (glut-swap-buffers) ) (define (play-proc) (let1 thistime (glut-get GLUT_ELAPSED_TIME) (inc! *rotl* (* (- thistime *lasttime*) -0.001)) (set! *lasttime* thistime) (glut-post-redisplay))) (define (key-proc key x y) (cond ((eqv? key (char->integer #\b)) (next-clear-color)) ((eqv? key (char->integer #\q)) (exit)) ((eqv? key (char->integer #\t)) (pop! *models*)) ((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 "t - Toggle among models to render") (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*)) )) ;;; ;;; draw-cube (original source is draw.c) ;;; (define (draw-cube) (let* ((size 1.0) (scale 0.2) (delta 0.1) (-size (- size)) (A (f32vector size size (+ (* size scale) delta))) (B (f32vector size size (+ (* -size scale) delta))) (C (f32vector size -size (* -size scale))) (D (f32vector size -size (* size scale))) (E (f32vector -size size (+ (* size scale) delta))) (F (f32vector -size size (+ (* -size scale) delta))) (G (f32vector -size -size (* -size scale))) (H (f32vector -size -size (* size scale))) (I '#f32( 1.0 0.0 0.0)) (K '#f32(-1.0 0.0 0.0)) (L '#f32( 0.0 0.0 -1.0)) (M '#f32( 0.0 0.0 1.0)) (N '#f32( 0.0 1.0 0.0)) (O '#f32( 0.0 -1.0 0.0)) ) (gl-begin GL_QUADS) (for-each (match-lambda ((n v0 v1 v2 v3) (gl-normal n) (gl-tex-coord 1 1) (gl-vertex v0) (gl-tex-coord 0 1) (gl-vertex v1) (gl-tex-coord 0 0) (gl-vertex v2) (gl-tex-coord 1 0) (gl-vertex v3))) `((,I ,D ,C ,B ,A) (,K ,G ,H ,E ,F) (,L ,C ,G ,F ,B) (,M ,H ,D ,A ,E) (,N ,E ,A ,B ,F) (,O ,G ,C ,D ,H))) (gl-end) )) ;;; ;;; shader stuff (original source is 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-brick-shaders vsh fsh) ;; Create a vertex shader object and a fragment shader object (let* ((brickvs (gl-create-shader-object-arb GL_VERTEX_SHADER_ARB)) (brickfs (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 brickvs (list vsh)) (gl-shader-source-arb brickfs (list fsh)) ;; Compile the brick vertex shader, and print out ;; the compiler log file. (gl-compile-shader-arb brickvs) (print-opengl-error) ;; Check for OpenGL errors (set! vert-compiled (gl-get-object-parameter-arb brickvs GL_OBJECT_COMPILE_STATUS_ARB)) (print-info-log brickvs) ;; Compile the brick fragment shader, and print out ;; the compiler log file. (gl-compile-shader-arb brickfs) (print-opengl-error) (set! frag-compiled (gl-get-object-parameter-arb brickfs GL_OBJECT_COMPILE_STATUS_ARB)) (print-info-log brickfs) (if (or (zero? vert-compiled) (zero? frag-compiled)) #f ;; failure ;; Create a program object and attach the two compiled shaders (let1 brickprog (gl-create-program-object-arb) (gl-attach-object-arb brickprog brickvs) (gl-attach-object-arb brickprog brickfs) ;; Link the program object and print out the info log (gl-link-program-arb brickprog) (print-opengl-error) (set! linked (gl-get-object-parameter-arb brickprog GL_OBJECT_LINK_STATUS_ARB)) (print-info-log brickprog) (if (zero? linked) #f ;; failure (begin ;; Install program object as part of current state (gl-use-program-object-arb brickprog) (gl-uniform3-arb (get-uniloc brickprog "BrickColor") 1.0 0.3 0.2) (gl-uniform3-arb (get-uniloc brickprog "MortarColor") 0.85 0.86 0.84) (gl-uniform2-arb (get-uniloc brickprog "BrickSize") 0.30 0.15) (gl-uniform2-arb (get-uniloc brickprog "BrickPct") 0.90 0.85) (gl-uniform3-arb (get-uniloc brickprog "LightPosition") 0.0 0.0 4.0) #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 Brick Shader"))) (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) (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 "brick.vert")) (fs (file->string "brick.frag"))) (and (install-brick-shaders vs fs) (glut-main-loop))) 0))