Description: upstream change Origin: svn revision 7080 Reviewed-By: NIIBE Yutaka Last-Update: 2010-03-19 =================================================================== --- gauche-gl-0.4.4.orig/ChangeLog (revision 301) +++ gauche-gl-0.4.4/ChangeLog (working copy) @@ -1,3 +1,83 @@ +2009-03-04 Shiro Kawai + + * src/*.stub: Updated uses of obsoleted (return "...") to + (call "..."). + +2008-10-15 Shiro Kawai + + * src/math3d-lib.stub (quatf-set4!): Added. + +2008-06-10 Shiro Kawai + + * src/gauche-math3d.c (Scm_AxesToQuatfv): clamp the cos(theta) value + to avoid getting NaN from rounding error when we take acosf. + +2008-06-09 Shiro Kawai + + * src/math3d-lib.stub (f32vector->matrix4f!): added. + (matrix4f->rotation!, matrix4f->translation!): changed the argument + order to be consistent of other linear update APIs. + +2008-06-08 Shiro Kawai + + * lib/gl/simple/viewer.scm: changed to keep callback and local + state for each window individually. APIs may take optional + window name. Without explicit window name, those APIs touches + the global default settings, which will affect the windows + created after the call. + + * src/gauche-glut.c (Scm_GlutRegisterCallback), + src/gauche-glut.h, + src/glut-lib.stub (glut-display-func etc): Rewrote to support + per-window callbacks properly---the old version kept one + closure per callback, so it was impossible to register different + callbacks for multiple windows, and also it worked incorrectly + since the last registered closure were called for all windows. + Now we manage closure vectors associated to each window. + +2008-06-06 Shiro Kawai + + * lib/gl/simple/image.scm, lib/gl/simple-image.scm: Moved + gl.simple-image to gl.simple.image. + + * lib/gl/simple/viewer.scm: added. + * examples/simple/minimum-viewer.scm: added. + +2008-06-05 Shiro Kawai + + * src/gauche-math3d.c, src/gauche/math3d.h (Scm_VectorsToQuatf, + Scm_AxesToQuatf): renamed from Scm_{Two|Four}Vectors... + * src/math3d-lib.stub (vectors->quatf, axes->quatf): renamed + accordingly. + + * repository migrated to subversion. + + * src/math3d-lib.stub (quatf-conjugate!, 4vectors->quatf, + 4vectors->quatf!): added. + +2008-06-04 Shiro Kawai + + * src/glext-lib.stub (gl-active-texture, gl-client-active-texture): + added sans '-arb' versions, which were added in GL1.3. + + * src/math3d-lib.stub (vector4f-norm, matrix4f->translation, + matrix4f->translation!, 2vectors->quatf, 2vectors->quatf!, + vector4f-mul, vector4f-mul!, vector4f-div): added. + +2007-08-05 Shiro Kawai + + * src/gl-lib.stub (gl-tex-coord-pointer, gl-index-pointer): Wrong GL + functions were called. + +2007-08-04 Shiro Kawai + + * src/glext-lib.stub: Added support of the framebuffer object + extension. + * src/gl-lib.stub (gl-tex-image-2d): allow passing #f to the texture + texels array so that it is possible to allocate texture memory but + not initialize it. It is useful when you want to render to + the texture. + 2007-07-09 Shiro Kawai * release 0.4.4 =================================================================== --- gauche-gl-0.4.4.orig/src/gl-lib.stub (revision 301) +++ gauche-gl-0.4.4/src/gl-lib.stub (working copy) @@ -1,7 +1,7 @@ ;;; ;;; gl-lib.stub - glue functions for GL ;;; -;;; Copyright(C) 2001-2005 by Shiro Kawai (shiro@acm.org) +;;; Copyright (c) 2001-2008 Shiro Kawai ;;; ;;; Permission to use, copy, modify, distribute this software and ;;; accompanying documentation for any purpose is hereby granted, @@ -31,6 +31,15 @@ } while (0) " +(define-cise-stmt assert-vector-type&size + [(_ type size var) + (let* ([TYPE (string-upcase (x->string type))] + [pred (string->symbol #`"SCM_,|TYPE|P")] + [getsize (string->symbol #`"SCM_,|TYPE|_SIZE")] + [msg #`",type of size ,size required,, but got %S"]) + `(when (or (not (,pred ,var)) (!= (,getsize ,var) ,size)) + (Scm_Error ,msg ,var)))]) + ;; NB: this should be taken care of by genstub. (define-type "ScmUVector*" "uniform vector" "SCM_UVECTORP" "SCM_UVECTOR") @@ -45,401 +54,295 @@ ;; stuff ;; -(define-cproc list->gl-boolean-vector (lis) - (return "Scm_ListToGLBooleanVector")) +(define-cproc list->gl-boolean-vector (lis) Scm_ListToGLBooleanVector) +(define-cproc gl-boolean-vector (&rest lis) Scm_ListToGLBooleanVector) +(define-cproc gl-boolean-vector? (obj) :: SCM_GL_BOOLEAN_VECTOR_P) -(define-cproc gl-boolean-vector (&rest lis) - (return "Scm_ListToGLBooleanVector")) - -(define-cproc gl-boolean-vector? (obj) - (return "SCM_GL_BOOLEAN_VECTOR_P")) - (define-cproc make-gl-boolean-vector (size:: &optional (init:: #f)) - (return "Scm_MakeGLBooleanVector")) + Scm_MakeGLBooleanVector) (define-cproc gl-boolean-vector-copy (bv::) - "SCM_RETURN(Scm_MakeGLBooleanVectorFromArray(bv->size, bv->elements));") + (result (Scm_MakeGLBooleanVectorFromArray (-> bv size) (-> bv elements)))) (define-cproc gl-boolean-vector-ref (bv:: k:: &optional fallback) - "if (k < 0 || k >= bv->size) { - if (SCM_UNBOUNDP(fallback)) { - Scm_Error(\"argument out of bound: %d\", k); - } - SCM_RETURN(fallback); - } else { - SCM_RETURN(SCM_MAKE_BOOL(bv->elements[k])); - }") + (cond [(or (< k 0) (>= k (-> bv size))) + (when (SCM_UNBOUNDP fallback) + (Scm_Error "argument out of bound: %d" k)) + (result fallback)] + [else + (result (SCM_MAKE_BOOL (aref (-> bv elements) k)))])) (define-cproc gl-boolean-vector-set! (bv:: k:: value) - "if (k < 0 || k >= bv->size) { - Scm_Error(\"argument out of bound: %d\", k); - } else { - bv->elements[k] = SCM_FALSEP(value)? GL_FALSE : GL_TRUE; - } - SCM_RETURN(SCM_UNDEFINED);") + :: + (if (or (< k 0) (>= k (-> bv size))) + (Scm_Error "argument out of bound: %d" k) + (= (aref (-> bv elements) k) (?: (SCM_FALSEP value) GL_FALSE GL_TRUE)))) -(define-cproc gl-boolean-vector-length (bv::) - "SCM_RETURN(SCM_MAKE_INT(bv->size));") +(define-cproc gl-boolean-vector-length (bv::) :: + (result (-> bv size))) (define-cproc gl-boolean-vector-fill! (bv:: fill) - "int i; - GLboolean val = SCM_FALSEP(fill)? GL_FALSE : GL_TRUE; - for (i=0; isize; i++) { - bv->elements[i] = val; - } - SCM_RETURN(SCM_OBJ(bv));") + (let* ([val::GLboolean (?: (SCM_FALSEP fill) GL_FALSE GL_TRUE)]) + (dotimes [i (-> bv size)] (= (aref (-> bv elements) i) val))) + (result (SCM_OBJ bv))) ;;============================================================= ;; Miscellaneous ;; -(define-cproc gl-clear-index (c::) - (return "glClearIndex")) - +(define-cproc gl-clear-index (c::) :: glClearIndex) (define-cproc gl-clear-color (r:: g:: b:: a::) - (return "glClearColor")) - -(define-cproc gl-clear (mask::) - (return "glClear")) - -(define-cproc gl-index-mask (mask::) - (return "glIndexMask")) - + :: glClearColor) +(define-cproc gl-clear (mask::) :: glClear) +(define-cproc gl-index-mask (mask::) :: glIndexMask) (define-cproc gl-color-mask (r:: g:: b:: a::) - (return "glColorMask")) + :: glColorMask) (define-cproc gl-alpha-func (func:: ref::) - (return "glAlphaFunc")) - + :: glAlphaFunc) (define-cproc gl-blend-func (sfactor:: dfactor::) - (return "glBlendFunc")) - -(define-cproc gl-logic-op (opcode::) - (return "glLogicOp")) - -(define-cproc gl-cull-face (mode::) - (return "glCullFace")) - -(define-cproc gl-front-face (mode::) - (return "glFrontFace")) - -(define-cproc gl-point-size (size::) - (return "glPointSize")) - -(define-cproc gl-line-width (width::) - (return "glLineWidth")) - + :: glBlendFunc) +(define-cproc gl-logic-op (opcode::) :: glLogicOp) +(define-cproc gl-cull-face (mode::) :: glCullFace) +(define-cproc gl-front-face (mode::) :: glFrontFace) +(define-cproc gl-point-size (size::) :: glPointSize) +(define-cproc gl-line-width (width::) :: glLineWidth) (define-cproc gl-line-stipple (factor:: pat::) - (return "glLineStipple")) - + :: glLineStipple) (define-cproc gl-polygon-mode (face:: mode::) - (return "glPolygonMode")) - + :: glPolygonMode) (define-cproc gl-polygon-offset (factor:: units::) - (return "glPolygonOffset")) + :: glPolygonOffset) -(define-cproc gl-polygon-stipple (mask) - " if (!SCM_U8VECTORP(mask) || SCM_U8VECTOR_SIZE(mask) != 128) { - Scm_Error(\"u8vector of size 128 required, but got %S\", mask); - } - glPolygonStipple(SCM_U8VECTOR_ELEMENTS(mask)); - SCM_RETURN(SCM_UNDEFINED);") +(define-cproc gl-polygon-stipple (mask) :: + (assert-vector-type&size u8vector 128 mask) + (glPolygonStipple (SCM_U8VECTOR_ELEMENTS mask))) -(define-cproc gl-edge-flag (flag) - "if (SCM_GL_BOOLEAN_VECTOR_P(flag)) { - glEdgeFlagv(SCM_GL_BOOLEAN_VECTOR(flag)->elements); - } else { - glEdgeFlag(!SCM_FALSEP(flag)); - } - SCM_RETURN(SCM_UNDEFINED);") +(define-cproc gl-edge-flag (flag) :: + (if (SCM_GL_BOOLEAN_VECTOR_P flag) + (glEdgeFlagv (-> (SCM_GL_BOOLEAN_VECTOR flag) elements)) + (glEdgeFlag (not (SCM_FALSEP flag))))) (define-cproc gl-scissor (x:: y:: width:: height::) - (return "glScissor")) + :: glScissor) -(define-cproc gl-clip-plane (plane:: equation) - "if (!SCM_F64VECTORP(equation) || SCM_F64VECTOR_SIZE(equation) != 4) { - Scm_Error(\"f64vector of size 4 required for EQUATION, but got %S\", equation); - } - glClipPlane(plane, SCM_F64VECTOR_ELEMENTS(equation)); - SCM_RETURN(SCM_UNDEFINED);") +(define-cproc gl-clip-plane (plane:: equation) :: + (assert-vector-type&size f64vector 4 equation) + (glClipPlane plane (SCM_F64VECTOR_ELEMENTS equation))) (define-cproc gl-get-clip-plane (plane::) - " ScmF64Vector *v = SCM_F64VECTOR(Scm_MakeF64Vector(4, 0.0)); - glGetClipPlane(plane, SCM_F64VECTOR_ELEMENTS(v)); - SCM_RETURN(SCM_OBJ(v));") + (let* ([v::ScmF64Vector* (SCM_F64VECTOR (Scm_MakeF64Vector 4 0.0))]) + (glGetClipPlane plane (SCM_F64VECTOR_ELEMENTS v)) + (result (SCM_OBJ v)))) -(define-cproc gl-draw-buffer (mode::) - (return "glDrawBuffer")) +(define-cproc gl-draw-buffer (mode::) :: glDrawBuffer) +(define-cproc gl-read-buffer (mode::) :: glReadBuffer) -(define-cproc gl-read-buffer (mode::) - (return "glReadBuffer")) +(define-cproc gl-enable (cap::) :: glEnable) +(define-cproc gl-disable (cap::) :: glDisable) +(define-cproc gl-is-enabled (cap::) :: glIsEnabled) -(define-cproc gl-enable (cap::) - (return "glEnable")) - -(define-cproc gl-disable (cap::) - (return "glDisable")) - -(define-cproc gl-is-enabled (cap::) - (return "glIsEnabled")) - (define-cproc gl-enable-client-state (cap::) - (return "glEnableClientState")) - + :: glEnableClientState) (define-cproc gl-disable-client-state (cap::) - (return "glDisableClientState")) + :: glDisableClientState) ;; Gauche-gl specific (define-cproc gl-state-vector-size (state::) - (return "Scm_GLStateInfoSize")) + :: Scm_GLStateInfoSize) +(define-cise-stmt with-state-info-size + [(_ var state name . body) + `(let* ([,var :: int (Scm_GLStateInfoSize ,state)]) + (when (<= ,var 0) + (Scm_Error ,#`"you can't query state %x by ,name" ,state)) + ,@body)]) + (define-cproc gl-get-boolean (state::) - "int vsize = Scm_GLStateInfoSize(state); - if (vsize <= 0) - Scm_Error(\"you can't query state %x by glGetBooleanv\", state); - if (vsize == 1) { - GLboolean b; - glGetBooleanv((GLenum)state, &b); - SCM_RETURN(SCM_MAKE_BOOL(b)); - } else { - ScmObj v = Scm_MakeGLBooleanVector(vsize, GL_FALSE); - glGetBooleanv((GLenum)state, SCM_GL_BOOLEAN_VECTOR(v)->elements); - SCM_RETURN(v); - }") + (with-state-info-size + vsize state gl-get-boolean + (if (== vsize 1) + (let* ([b::GLboolean]) + (glGetBooleanv (cast GLenum state) (& b)) + (result (SCM_MAKE_BOOL b))) + (let* ([v (Scm_MakeGLBooleanVector vsize GL_FALSE)]) + (glGetBooleanv (cast GLenum state) + (-> (SCM_GL_BOOLEAN_VECTOR v) elements)) + (result v))))) -(define-cproc gl-get-boolean! (vec state::) - "int vsize; - if (!SCM_GL_BOOLEAN_VECTOR_P(vec)) - Scm_Error(\"gl-boolean-vector required, but got %S\", vec); - vsize = Scm_GLStateInfoSize(state); - if (vsize != SCM_GL_BOOLEAN_VECTOR_SIZE(vec)) - Scm_Error(\"state %x needs a vector of size %d, but got %S\", - state, vsize, vec); - glGetBooleanv((GLenum)state, SCM_GL_BOOLEAN_VECTOR(vec)->elements); - SCM_RETURN(SCM_OBJ(vec));") +(define-cproc gl-get-boolean! (vec:: state::) + (with-state-info-size + vsize state gl-get-boolean! + (when (!= vsize (SCM_GL_BOOLEAN_VECTOR_SIZE vec)) + (Scm_Error "state %x needs a vector of size %d, but got %S" + state vsize (SCM_OBJ vec))) + (glGetBooleanv (cast GLenum state) (-> vec elements)) + (result (SCM_OBJ vec)))) (define-cproc gl-get-integer (state::) - "int vsize = Scm_GLStateInfoSize(state); - if (vsize <= 0) - Scm_Error(\"you can't query state %x by glGetIntegerv\", state); - if (vsize == 1) { - GLint i; - glGetIntegerv((GLenum)state, &i); - SCM_RETURN(Scm_MakeInteger(i)); - } else { - ScmS32Vector *v = SCM_S32VECTOR(Scm_MakeS32Vector(vsize, 0)); - glGetIntegerv((GLenum)state, (GLint*)SCM_S32VECTOR_ELEMENTS(v)); - SCM_RETURN(SCM_OBJ(v)); - }") + (with-state-info-size + vsize state gl-get-integer + (if (== vsize 1) + (let* ([i::GLint]) + (glGetIntegerv (cast GLenum state) (& i)) + (result (Scm_MakeInteger i))) + (let* ([v::ScmS32Vector* (SCM_S32VECTOR (Scm_MakeS32Vector vsize 0))]) + (glGetIntegerv (cast GLenum state) + (cast GLint* (SCM_S32VECTOR_ELEMENTS v))) + (result (SCM_OBJ v)))))) -(define-cproc gl-get-integer! (vec state::) - "int vsize; - if (!SCM_S32VECTORP(vec)) Scm_Error(\"s32vector required, but got %S\", vec); - vsize = Scm_GLStateInfoSize(state); - if (vsize != SCM_S32VECTOR_SIZE(vec)) - Scm_Error(\"state %x needs a vector of size %d, but got %S\", - state, vsize, vec); - glGetIntegerv((GLenum)state, (GLint*)SCM_S32VECTOR_ELEMENTS(vec)); - SCM_RETURN(SCM_OBJ(vec));") +(define-cproc gl-get-integer! (vec:: state::) + (with-state-info-size + vsize state gl-get-integer! + (when (!= vsize (SCM_S32VECTOR_SIZE vec)) + (Scm_Error "state %x needs a vector of size %d, but got %S" + state vsize vec)) + (glGetIntegerv (cast GLenum state) + (cast GLint* (SCM_S32VECTOR_ELEMENTS vec))) + (result (SCM_OBJ vec)))) (define-cproc gl-get-float (state::) - "int vsize = Scm_GLStateInfoSize(state); - if (vsize <= 0) - Scm_Error(\"you can't query state %x by glGetFloatv\", state); - if (vsize == 1) { - GLfloat v; - glGetFloatv((GLenum)state, &v); - SCM_RETURN(Scm_MakeFlonum((double)v)); - } else { - ScmF32Vector *v = SCM_F32VECTOR(Scm_MakeF32Vector(vsize, 0)); - glGetFloatv((GLenum)state, SCM_F32VECTOR_ELEMENTS(v)); - SCM_RETURN(SCM_OBJ(v)); - }") + (with-state-info-size + vsize state gl-get-float + (if (== vsize 1) + (let* ([v::GLfloat]) + (glGetFloatv (cast GLenum state) (& v)) + (result (Scm_MakeFlonum (cast double v)))) + (let* ([v::ScmF32Vector* (SCM_F32VECTOR (Scm_MakeF32Vector vsize 0))]) + (glGetFloatv (cast GLenum state) (SCM_F32VECTOR_ELEMENTS v)) + (result (SCM_OBJ v)))))) -(define-cproc gl-get-float! (vec state::) - "int vsize; - if (!SCM_F32VECTORP(vec)) Scm_Error(\"s32vector required, but got %S\", vec); - vsize = Scm_GLStateInfoSize(state); - if (vsize != SCM_F32VECTOR_SIZE(vec)) - Scm_Error(\"state %x needs a vector of size %d, but got %S\", - state, vsize, vec); - glGetFloatv((GLenum)state, SCM_F32VECTOR_ELEMENTS(vec)); - SCM_RETURN(SCM_OBJ(vec));") +(define-cproc gl-get-float! (vec:: state::) + (with-state-info-size + vsize state gl-get-float! + (when (!= vsize (SCM_F32VECTOR_SIZE vec)) + (Scm_Error "state %x needs a vector of size %d, but got %S" + state vsize vec)) + (glGetFloatv (cast GLenum state) (SCM_F32VECTOR_ELEMENTS vec)) + (result (SCM_OBJ vec)))) (define-cproc gl-get-double (state::) - "int vsize = Scm_GLStateInfoSize(state); - if (vsize <= 0) - Scm_Error(\"you can't query state %x by glGetDoublev\", state); - if (vsize == 1) { - GLdouble v; - glGetDoublev((GLenum)state, &v); - SCM_RETURN(Scm_MakeFlonum(v)); - } else { - ScmF64Vector *v = SCM_F64VECTOR(Scm_MakeF64Vector(vsize, 0)); - glGetDoublev((GLenum)state, SCM_F64VECTOR_ELEMENTS(v)); - SCM_RETURN(SCM_OBJ(v)); - }") + (with-state-info-size + vsize state gl-get-double + (if (== vsize 1) + (let* ([v::GLdouble]) + (glGetDoublev (cast GLenum state) (& v)) + (result (Scm_MakeFlonum v))) + (let* ([v::ScmF64Vector* (SCM_F64VECTOR (Scm_MakeF64Vector vsize 0))]) + (glGetDoublev (cast GLenum state) (SCM_F64VECTOR_ELEMENTS v)) + (result (SCM_OBJ v)))))) -(define-cproc gl-get-double! (vec state::) - "int vsize; - if (!SCM_F64VECTORP(vec)) Scm_Error(\"s32vector required, but got %S\", vec); - vsize = Scm_GLStateInfoSize(state); - if (vsize != SCM_F64VECTOR_SIZE(vec)) - Scm_Error(\"state %x needs a vector of size %d, but got %S\", - state, vsize, vec); - glGetDoublev((GLenum)state, SCM_F64VECTOR_ELEMENTS(vec)); - SCM_RETURN(SCM_OBJ(vec));") +(define-cproc gl-get-double! (vec:: state::) + (with-state-info-size + vsize state gl-get-double! + (when (!= vsize (SCM_F64VECTOR_SIZE vec)) + (Scm_Error "state %x needs a vector of size %d, but got %S" + state vsize vec)) + (glGetDoublev (cast GLenum state) (SCM_F64VECTOR_ELEMENTS vec)) + (result (SCM_OBJ vec)))) ;; glGetPointerv -(define-cproc gl-push-attrib (mask::) - (return "glPushAttrib")) +(define-cproc gl-push-attrib (mask::):: glPushAttrib) +(define-cproc gl-pop-attrib () :: glPopAttrib) +(define-cproc gl-push-client-attrib (mask::):: glPushClientAttrib) +(define-cproc gl-pop-client-attrib () :: glPopClientAttrib) -(define-cproc gl-pop-attrib () - (return "glPopAttrib")) +(define-cproc gl-render-mode (mode::) :: glRenderMode) -(define-cproc gl-push-client-attrib (mask::) - (return "glPushClientAttrib")) - -(define-cproc gl-pop-client-attrib () - (return "glPopClientAttrib")) - -(define-cproc gl-render-mode (mode::) - (return "glRenderMode")) - -(define-cproc gl-get-error () - (return "glGetError")) - +(define-cproc gl-get-error () :: glGetError) (define-cproc gl-get-string (name::) - "const GLubyte *s = glGetString(name); - if (s) SCM_RETURN(Scm_MakeString((const char*)s, -1, -1, SCM_MAKSTR_COPYING)); - else SCM_RETURN(SCM_FALSE);") + (let* ([s::(const GLubyte*) (glGetString name)]) + (if s + (result (Scm_MakeString (cast (const char*) s) -1 -1 SCM_MAKSTR_COPYING)) + (result SCM_FALSE)))) -(define-cproc gl-flush () - (return "glFlush")) +(define-cproc gl-flush () :: glFlush) +(define-cproc gl-finish () :: glFinish) +(define-cproc gl-hint (target:: mode::) :: glHint) -(define-cproc gl-finish () - (return "glFinish")) - -(define-cproc gl-hint (target:: mode::) - (return "glHint")) - ;;============================================================= ;; Depth Buffer ;; -(define-cproc gl-clear-depth (depth::) - (return "glClearDepth")) +(define-cproc gl-clear-depth (depth::):: glClearDepth) +(define-cproc gl-depth-func (func::):: glDepthFunc) +(define-cproc gl-depth-mask (flag::):: glDepthMask) +(define-cproc gl-depth-range (nearv:: farv::):: glDepthRange) -(define-cproc gl-depth-func (func::) - (return "glDepthFunc")) - -(define-cproc gl-depth-mask (flag::) - (return "glDepthMask")) - -(define-cproc gl-depth-range (nearv:: farv::) - (return "glDepthRange")) - ;;============================================================= ;; Accumulation Buffer ;; (define-cproc gl-clear-accum (r:: g:: b:: a::) - (return "glClearAccum")) + :: glClearAccum) +(define-cproc gl-accum (op:: value::) :: glAccum) -(define-cproc gl-accum (op:: value::) - (return "glAccum")) - ;;============================================================= ;; Transformation ;; -(define-cproc gl-matrix-mode (mode::) - (return "glMatrixMode")) +(define-cproc gl-matrix-mode (mode::) :: glMatrixMode) (define-cproc gl-ortho (left:: right:: bottom:: top:: nearv:: farv::) - (return "glOrtho")) + :: glOrtho) (define-cproc gl-frustum (left:: right:: bottom:: top:: nearv:: farv::) - (return "glFrustum")) + :: glFrustum) (define-cproc gl-viewport (x:: y:: width:: height::) - (return "glViewport")) + :: glViewport) -(define-cproc gl-push-matrix () - (return "glPushMatrix")) +(define-cproc gl-push-matrix () :: glPushMatrix) +(define-cproc gl-pop-matrix () :: glPopMatrix) +(define-cproc gl-load-identity () :: glLoadIdentity) -(define-cproc gl-pop-matrix () - (return "glPopMatrix")) +(define-cproc gl-load-matrix (m) :: + (cond [(SCM_MATRIX4FP m) (glLoadMatrixf (SCM_MATRIX4F_D m))] + [(and (SCM_F32VECTORP m) (== (SCM_F32VECTOR_SIZE m) 16)) + (glLoadMatrixf (SCM_F32VECTOR_ELEMENTS m))] + [(and (SCM_F64VECTORP m) (== (SCM_F64VECTOR_SIZE m) 16)) + (glLoadMatrixd (SCM_F64VECTOR_ELEMENTS m))] + [else (Scm_Error "matrix4f, or f32vector or f64vector of length 16 \ + is required, but got %S" m)])) -(define-cproc gl-load-identity () - (return "glLoadIdentity")) +(define-cproc gl-mult-matrix (m) :: + (cond [(SCM_MATRIX4FP m) (glMultMatrixf (SCM_MATRIX4F_D m))] + [(and (SCM_F32VECTORP m) (== (SCM_F32VECTOR_SIZE m) 16)) + (glMultMatrixf (SCM_F32VECTOR_ELEMENTS m))] + [(and (SCM_F64VECTORP m) (== (SCM_F64VECTOR_SIZE m) 16)) + (glMultMatrixd (SCM_F64VECTOR_ELEMENTS m))] + [else (Scm_Error "matrix4f, or f32vector or f64vector of length 16 \ + is required, but got %S" m)])) -(define-cproc gl-load-matrix (m) - "if (SCM_MATRIX4FP(m)) { - glLoadMatrixf(SCM_MATRIX4F_D(m)); - } else if (SCM_F32VECTORP(m) && SCM_F32VECTOR_SIZE(m) == 16) { - glLoadMatrixf(SCM_F32VECTOR_ELEMENTS(m)); - } else if (SCM_F64VECTORP(m) && SCM_F64VECTOR_SIZE(m) == 16) { - glLoadMatrixd(SCM_F64VECTOR_ELEMENTS(m)); - } else { - Scm_Error(\"matrix4f, or f32vector or f64vector of length 16 is required, but got %S\", m); - } - SCM_RETURN(SCM_UNDEFINED);") - -(define-cproc gl-mult-matrix (m) - "if (SCM_MATRIX4FP(m)) { - glMultMatrixf(SCM_MATRIX4F_D(m)); - } else if (SCM_F32VECTORP(m) && SCM_F32VECTOR_SIZE(m) == 16) { - glMultMatrixf(SCM_F32VECTOR_ELEMENTS(m)); - } else if (SCM_F64VECTORP(m) && SCM_F64VECTOR_SIZE(m) == 16) { - glMultMatrixd(SCM_F64VECTOR_ELEMENTS(m)); - } else { - Scm_Error(\"matrix4f, or f32vector or f64vector of length 16 is required, but got %S\", m); - } - SCM_RETURN(SCM_UNDEFINED);") - (define-cproc gl-rotate (angle:: x:: y:: z::) - (return "glRotated")) - + :: glRotated) (define-cproc gl-scale (x:: y:: z::) - (return "glScaled")) - + :: glScaled) (define-cproc gl-translate (x:: y:: z::) - (return "glTranslated")) + :: glTranslated) ;;============================================================= ;; Display lists ;; -(define-cproc gl-is-list (list::) - (return "glIsList")) +(define-cproc gl-is-list (list::):: glIsList) +(define-cproc gl-delete-lists (list:: range::) :: glDeleteLists) +(define-cproc gl-gen-lists (range::) :: glGenLists) +(define-cproc gl-new-list (list:: mode::) :: glNewList) +(define-cproc gl-end-list () :: glEndList) +(define-cproc gl-call-list (list::) :: glCallList) -(define-cproc gl-delete-lists (list:: range::) - (return "glDeleteLists")) - -(define-cproc gl-gen-lists (range::) - (return "glGenLists")) - -(define-cproc gl-new-list (list:: mode::) - (return "glNewList")) - -(define-cproc gl-end-list () - (return "glEndList")) - -(define-cproc gl-call-list (list::) - (return "glCallList")) - ;; this may be called as ;; (gl-call-lists array) ;; (gl-call-lists size array) @@ -536,19 +439,15 @@ Scm_Error(\"given type %d doesn't match the passed array (u8vector)\", type); SCM_RETURN(SCM_UNDEFINED);") -(define-cproc gl-list-base (base::) - (return "glListBase")) +(define-cproc gl-list-base (base::) :: glListBase) ;;============================================================= ;; Drawing functions ;; -(define-cproc gl-begin (mode::) - (return "glBegin")) +(define-cproc gl-begin (mode::) :: glBegin) +(define-cproc gl-end () :: glEnd) -(define-cproc gl-end () - (return "glEnd")) - (define-cproc gl-vertex (v &rest args) "if (SCM_POINT4FP(v) || SCM_VECTOR4FP(v)) { glVertex3fv(SCM_VECTOR4F_D(v)); @@ -926,20 +825,20 @@ Scm_Error(\"bad argument for offset: %d, must be 0 or positive\", offset); } if (SCM_S32VECTORP(vec)) { - glNormalPointer(GL_INT, stride*sizeof(GLint), - (void*)(SCM_S32VECTOR_ELEMENTS(vec)+offset)); + glIndexPointer(GL_INT, stride*sizeof(GLint), + (void*)(SCM_S32VECTOR_ELEMENTS(vec)+offset)); } else if (SCM_S16VECTORP(vec)) { - glNormalPointer(GL_SHORT, stride*sizeof(GLshort), - (void*)(SCM_S16VECTOR_ELEMENTS(vec)+offset)); + glIndexPointer(GL_SHORT, stride*sizeof(GLshort), + (void*)(SCM_S16VECTOR_ELEMENTS(vec)+offset)); } else if (SCM_U8VECTORP(vec)) { - glNormalPointer(GL_UNSIGNED_BYTE, stride*sizeof(GLubyte), - (void*)(SCM_U8VECTOR_ELEMENTS(vec)+offset)); + glIndexPointer(GL_UNSIGNED_BYTE, stride*sizeof(GLubyte), + (void*)(SCM_U8VECTOR_ELEMENTS(vec)+offset)); } else if (SCM_F32VECTORP(vec)) { - glNormalPointer(GL_FLOAT, stride*sizeof(GLfloat), - (void*)(SCM_F32VECTOR_ELEMENTS(vec)+offset)); + glIndexPointer(GL_FLOAT, stride*sizeof(GLfloat), + (void*)(SCM_F32VECTOR_ELEMENTS(vec)+offset)); } else if (SCM_F64VECTORP(vec)) { - glNormalPointer(GL_DOUBLE, stride*sizeof(GLdouble), - (void*)(SCM_F64VECTOR_ELEMENTS(vec)+offset)); + glIndexPointer(GL_DOUBLE, stride*sizeof(GLdouble), + (void*)(SCM_F64VECTOR_ELEMENTS(vec)+offset)); } else { Scm_Error(\"bad argument for vec: %S, must be f32, f64, u8, s16 or s32 vector\", vec); } @@ -958,17 +857,17 @@ Scm_Error(\"bad argument for offset: %d, must be 0 or positive\", offset); } if (SCM_F32VECTORP(vec)) { - glColorPointer(size, GL_FLOAT, stride*sizeof(GLfloat), - (void*)(SCM_F32VECTOR_ELEMENTS(vec)+offset)); + glTexCoordPointer(size, GL_FLOAT, stride*sizeof(GLfloat), + (void*)(SCM_F32VECTOR_ELEMENTS(vec)+offset)); } else if (SCM_F64VECTORP(vec)) { - glColorPointer(size, GL_DOUBLE, stride*sizeof(GLdouble), - (void*)(SCM_F64VECTOR_ELEMENTS(vec)+offset)); + glTexCoordPointer(size, GL_DOUBLE, stride*sizeof(GLdouble), + (void*)(SCM_F64VECTOR_ELEMENTS(vec)+offset)); } else if (SCM_S32VECTORP(vec)) { - glColorPointer(size, GL_INT, stride*sizeof(GLint), - (void*)(SCM_S32VECTOR_ELEMENTS(vec)+offset)); + glTexCoordPointer(size, GL_INT, stride*sizeof(GLint), + (void*)(SCM_S32VECTOR_ELEMENTS(vec)+offset)); } else if (SCM_S16VECTORP(vec)) { - glColorPointer(size, GL_SHORT, stride*sizeof(GLshort), - (void*)(SCM_S16VECTOR_ELEMENTS(vec)+offset)); + glTexCoordPointer(size, GL_SHORT, stride*sizeof(GLshort), + (void*)(SCM_S16VECTOR_ELEMENTS(vec)+offset)); } else { Scm_Error(\"bad argument for vec: %S, must be f32, f64, s16 or s32vector\", vec); } @@ -1006,7 +905,7 @@ (define-cproc gl-draw-arrays (mode:: first:: count::) - (return "glDrawArrays")) + :: glDrawArrays) ;; Note: we don't allow non-uniform vector for the interleaved arrays, so ;; the color component must be float. @@ -1028,8 +927,7 @@ ;; Lighting ;; -(define-cproc gl-shade-model (mode::) - (return "glShadeModel")) +(define-cproc gl-shade-model (mode::) :: glShadeModel) (define-cproc gl-light (light:: pname:: param) "switch (pname) { @@ -1162,14 +1060,14 @@ }") (define-cproc gl-color-material (face:: mode::) - (return "glColorMaterial")) + :: glColorMaterial) ;;============================================================= ;; Raster functions ;; (define-cproc gl-pixel-zoom (xfactor:: yfactor::) - (return "glPixelZoom")) + :: glPixelZoom) (define-cproc gl-pixel-store (pname:: param) "if (SCM_EXACTP(param)) { @@ -1273,31 +1171,29 @@ (define-cproc gl-draw-pixels (width:: height:: format:: type:: pixels) - " int elttype, size, packed; - size = Scm_GLPixelDataSize(width, height, format, type, &elttype, &packed); - glDrawPixels(width, height, format, type, - Scm_GLPixelDataCheck(pixels, elttype, size)); - SCM_RETURN(SCM_UNDEFINED);") + :: + (let* ([elttype::int] [packed::int] + [size::int (Scm_GLPixelDataSize width height format type + (& elttype) (& packed))]) + (glDrawPixels width height format type + (Scm_GLPixelDataCheck pixels elttype size)))) (define-cproc gl-copy-pixels (x:: y:: width:: height:: type::) - (return "glCopyPixels")) + :: glCopyPixels) ;;============================================================= ;; Stenciling ;; (define-cproc gl-stencil-func (func:: ref:: mask::) - (return "glStencilFunc")) - + :: glStencilFunc) (define-cproc gl-stencil-mask (mask::) - (return "glStencilMask")) - + :: glStencilMask) (define-cproc gl-stencil-op (func:: zfail:: zpass::) - (return "glStencilOp")) - + :: glStencilOp) (define-cproc gl-clear-stencil (s::) - (return "glClearStencil")) + :: glClearStencil) ;;============================================================= ;; Texture mapping @@ -1439,22 +1335,30 @@ SCM_RETURN(SCM_UNDEFINED); }") -;; Caller must ensure vector has enough length +;; Caller must ensure vector has enough length, since we need to get +;; pixel store parameters to check that, which is expensive. +;; We allow #f to TEXELS just to allcate texture area (to be used +;; as a render target via framebuffer object). (define-cproc gl-tex-image-1d (target:: level:: internalformat:: width:: border:: format:: type:: texels) "int elttype, size; void *texelptr; size = Scm_GLPixelDataSize(width, 1, format, type, &elttype, NULL); - texelptr = Scm_GLPixelDataCheck(texels, elttype, size); - if (texelptr) { + if (SCM_FALSEP(texels)) { + texelptr = NULL; + } else { + texelptr = Scm_GLPixelDataCheck(texels, elttype, size); glTexImage1D(target, level, internalformat, width, border, format, type, texelptr); } SCM_RETURN(SCM_UNDEFINED);") -;; caller must ensure vector has enough length +;; Caller must ensure vector has enough length, since we need to get +;; pixel store parameters to check that, which is expensive. +;; We allow #f to TEXELS just to allcate texture area (to be used +;; as a render target via framebuffer object). (define-cproc gl-tex-image-2d (target:: level:: internalformat:: width:: height:: @@ -1462,100 +1366,97 @@ type:: texels) "int elttype, size; void *texelptr; size = Scm_GLPixelDataSize(width, height, format, type, &elttype, NULL); - texelptr = Scm_GLPixelDataCheck(texels, elttype, size); - if (texelptr) { - glTexImage2D(target, level, internalformat, width, height, border, format, type, texelptr); + if (SCM_FALSEP(texels)) { + texelptr = NULL; + } else { + texelptr = Scm_GLPixelDataCheck(texels, elttype, size); + glTexImage2D(target, level, internalformat, width, height, border, format, type, texelptr); } SCM_RETURN(SCM_UNDEFINED);") ; gl-get-tex-image (define-cproc gl-gen-textures (size::) - "ScmObj vec; - if (size <= 0) Scm_Error(\"size must be a positive integer, but got %d\", size); - vec = Scm_MakeU32Vector(size, 0); - glGenTextures(size, (GLuint*)SCM_U32VECTOR_ELEMENTS(vec)); - SCM_RETURN(vec);") + (when (<= size 0) + (Scm_Error "size must be a positive integer, but got %d" size)) + (let* ([vec (Scm_MakeU32Vector size 0)]) + (glGenTextures size (cast GLuint* (SCM_U32VECTOR_ELEMENTS vec))) + (result vec))) -(define-cproc gl-delete-textures (names) - "if (!SCM_U32VECTORP(names)) Scm_Error(\"texture names must be an u32vector, but got %S\", names); - glDeleteTextures(SCM_U32VECTOR_SIZE(names), - (GLuint*)SCM_U32VECTOR_ELEMENTS(names)); - SCM_RETURN(SCM_UNDEFINED);") +(define-cproc gl-delete-textures (names::) :: + (glDeleteTextures (SCM_U32VECTOR_SIZE names) + (cast GLuint* (SCM_U32VECTOR_ELEMENTS names)))) -(define-cproc gl-bind-texture (target:: name::) - "glBindTexture(target, name); - SCM_RETURN(SCM_UNDEFINED);") +(define-cproc gl-bind-texture (target:: name::) :: + glBindTexture) (define-cproc gl-prioritize-textures (names:: priorities::) - "int n = SCM_U32VECTOR_SIZE(names); - if (n != SCM_F32VECTOR_SIZE(priorities)) { - Scm_Error(\"priority vector length doesn't match the names vector length %d: %S\", n, priorities); - } - glPrioritizeTextures(n, (GLuint*)SCM_U32VECTOR_ELEMENTS(names), - SCM_F32VECTOR_ELEMENTS(priorities)); - SCM_RETURN(SCM_UNDEFINED);") + :: + (let* ([n::int (SCM_U32VECTOR_SIZE names)]) + (when (!= n (SCM_F32VECTOR_SIZE priorities)) + (Scm_Error "priority vector length doesn't match \ + the names vector length %d: %S" n priorities)) + (glPrioritizeTextures n (cast GLuint* (SCM_U32VECTOR_ELEMENTS names)) + (SCM_F32VECTOR_ELEMENTS priorities)))) (define-cproc gl-are-textures-resident! (names:: res::) - "GLboolean b; int n; - n = SCM_U32VECTOR_SIZE(names); - b = glAreTexturesResident(n, (GLuint*)SCM_U32VECTOR_ELEMENTS(names), - SCM_GL_BOOLEAN_VECTOR_ELEMENTS(res)); - SCM_RETURN(SCM_MAKE_BOOL(b));") + :: + (glAreTexturesResident (SCM_U32VECTOR_SIZE names) + (cast GLuint* (SCM_U32VECTOR_ELEMENTS names)) + (SCM_GL_BOOLEAN_VECTOR_ELEMENTS res))) -(define-cproc gl-is-texture (name::) - "SCM_RETURN(SCM_MAKE_INT(glIsTexture(name)));") +(define-cproc gl-is-texture (name::) :: glIsTexture) (define-cproc gl-tex-sub-image-1d (target:: level:: xoffset:: width:: format:: type:: texels) - "int elttype, size; void *texelptr; - size = Scm_GLPixelDataSize(width, 1, format, type, &elttype, NULL); - texelptr = Scm_GLPixelDataCheck(texels, elttype, size); - if (texelptr) { - glTexSubImage1D(target, level, xoffset, width, format, type, texelptr); - } - SCM_RETURN(SCM_UNDEFINED);") + :: + (let* ([elttype::int] + [size::int (Scm_GLPixelDataSize width 1 format type (& elttype) NULL)] + [texelptr::void* (Scm_GLPixelDataCheck texels elttype size)]) + (when texelptr + (glTexSubImage1D target level xoffset width format type texelptr)))) (define-cproc gl-tex-sub-image-2d (target:: level:: xoffset:: yoffset:: width:: height:: format:: type:: texels) - "int elttype, size; void *texelptr; - size = Scm_GLPixelDataSize(width, height, format, type, &elttype, NULL); - texelptr = Scm_GLPixelDataCheck(texels, elttype, size); - if (texelptr) { - glTexSubImage2D(target, level, xoffset, yoffset, width, height, format, type, texelptr); - } - SCM_RETURN(SCM_UNDEFINED);") + :: + (let* ([elttype::int] + [size::int + (Scm_GLPixelDataSize width height format type (& elttype) NULL)] + [texelptr::void* (Scm_GLPixelDataCheck texels elttype size)]) + (when texelptr + (glTexSubImage2D target level xoffset yoffset width height + format type texelptr)))) (define-cproc gl-copy-tex-image-1d (target:: level:: internal-format:: x:: y:: width:: border::) - (return "glCopyTexImage1D")) + :: glCopyTexImage1D) (define-cproc gl-copy-tex-image-2d (target:: level:: internal-format:: x:: y:: width:: height:: border::) - (return "glCopyTexImage2D")) + :: glCopyTexImage2D) (define-cproc gl-copy-tex-sub-image-1d (target:: level:: xoffset:: x:: y:: width::) - (return "glCopyTexSubImage1D")) + :: glCopyTexSubImage1D) (define-cproc gl-copy-tex-sub-image-2d (target:: level:: xoffset:: yoffset:: x:: y:: width:: height::) - (return "glCopyTexSubImage2D")) + :: glCopyTexSubImage2D) ;;============================================================= ;; Evaluators @@ -1576,36 +1477,20 @@ ;; Fog ;; -(define-cproc gl-fog (pname:: param) - "switch (pname) { - case GL_FOG_MODE:; - case GL_FOG_INDEX:; - if (SCM_INTP(param)) { - glFogi(pname, SCM_INT_VALUE(param)); - } else { - Scm_Error(\"integer parameter required, but got %S\", param); - } - break; - case GL_FOG_DENSITY:; - case GL_FOG_START:; - case GL_FOG_END:; - if (SCM_REALP(param)) { - glFogf(pname, (GLfloat)Scm_GetDouble(param)); - } else { - Scm_Error(\"real number parameter required, but got %S\", param); - } - break; - case GL_FOG_COLOR: - if (SCM_F32VECTORP(param) && SCM_F32VECTOR_SIZE(param) == 4) { - glFogfv(pname, SCM_F32VECTOR_ELEMENTS(param)); - } else { - Scm_Error(\"f32 vector of size 4 is required, but got %S\", param); - } - break; - default: - Scm_Error(\"unknown or unsupported glFog pname: %d\", pname); - } - SCM_RETURN(SCM_UNDEFINED);") +(define-cproc gl-fog (pname:: param) :: + (case pname + [(GL_FOG_MODE GL_FOG_INDEX) + (if (SCM_INTP param) + (glFogi pname (SCM_INT_VALUE param)) + (Scm_Error "integer parameter required, but got %S" param))] + [(GL_FOG_DENSITY GL_FOG_START GL_FOG_END) + (if (SCM_REALP param) + (glFogf pname (cast GLfloat (Scm_GetDouble param))) + (Scm_Error "real number parameter required, but got %S" param))] + [(GL_FOG_COLOR) + (assert-vector-type&size f32vector 4 param) + (glFogfv pname (SCM_F32VECTOR_ELEMENTS param))] + [else (Scm_Error "unknown or unsupported glFog pname: %d" pname)])) ;;============================================================= ;; Selection and feedback @@ -1613,30 +1498,21 @@ (define-cproc gl-feedback-buffer (type:: buffer::) - "glFeedbackBuffer(SCM_F32VECTOR_SIZE(buffer), type, - SCM_F32VECTOR_ELEMENTS(buffer)); - SCM_RETURN(SCM_UNDEFINED);") + :: + (glFeedbackBuffer (SCM_F32VECTOR_SIZE buffer) type + (SCM_F32VECTOR_ELEMENTS buffer))) -(define-cproc gl-select-buffer (buffer::) - "glSelectBuffer(SCM_U32VECTOR_SIZE(buffer), - (GLuint*)SCM_U32VECTOR_ELEMENTS(buffer)); - SCM_RETURN(SCM_UNDEFINED);") +(define-cproc gl-select-buffer (buffer::) :: + (glSelectBuffer (SCM_U32VECTOR_SIZE buffer) + (cast GLuint* (SCM_U32VECTOR_ELEMENTS buffer)))) -(define-cproc gl-pass-through (token::) - (return "glPassThrough")) +(define-cproc gl-pass-through (token::) :: glPassThrough) -(define-cproc gl-init-names () - (return "glInitNames")) +(define-cproc gl-init-names () :: glInitNames) +(define-cproc gl-load-name (name::) :: glLoadName) +(define-cproc gl-push-name (name::) :: glPushName) +(define-cproc gl-pop-name () :: glPopName) -(define-cproc gl-load-name (name::) - (return "glLoadName")) - -(define-cproc gl-push-name (name::) - (return "glPushName")) - -(define-cproc gl-pop-name () - (return "glPopName")) - ;; Local variables: ;; mode: scheme ;; end: =================================================================== --- gauche-gl-0.4.4.orig/src/gauche-glut.c (revision 301) +++ gauche-gl-0.4.4/src/gauche-glut.c (working copy) @@ -1,7 +1,7 @@ /* * gauche-glut.c - Gauche GLUT binding * - * Copyright(C) 2001 by Shiro Kawai (shiro@acm.org) + * Copyright (c) 2001-2008 Shiro Kawai * * Permission to use, copy, modify, distribute this software and * accompanying documentation for any purpose is hereby granted, @@ -27,6 +27,10 @@ extern void Scm_Init_glut_lib(ScmModule *mod); +/*================================================================ + * Glut font + */ + SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_GlutFontClass, NULL); static ScmObj makeGlutFont(void *ptr) @@ -37,6 +41,250 @@ return SCM_OBJ(gf); } +/*================================================================ + * Callback support. + * + * Glut callbacks are associated to the "current window". + * unfortunately the callback interface doesn't allow us + * to pass extra data pointer, so our C callback routine + * doesn't know which Scheme closure to be called. We maintain + * that information in our table. + * + * TODO: We don't want to use Scm_ApplyRec, for we need to cons + * the arguments (display is ok, but motion and passiveMotion generates + * garbages which will eventurally trigger GC.) Rewrite *_cb functions + * after we implement Scm_ApplyRec0, Scm_ApplyRec1, .., etc. in + * Gauche core. + */ + +static ScmObj ScmGlutCallbackTable = SCM_UNDEFINED; /* set by init routine */ + +static ScmObj get_callback(int type) +{ + int win = glutGetWindow(); + ScmObj entry = Scm_HashTableRef(SCM_HASH_TABLE(ScmGlutCallbackTable), + SCM_MAKE_INT(win), SCM_FALSE); + SCM_ASSERT(type >= 0 && type < SCM_GLUT_NUM_WINDOW_CBS); + if (SCM_VECTORP(entry)) { + return SCM_VECTOR_ELEMENT(entry, type); + } else { + return SCM_FALSE; + } +} + +#define define_callback(name, num, arglist, args) \ + static void SCM_CPP_CAT(name, _cb) arglist \ + { \ + ScmObj cb = get_callback(SCM_CPP_CAT(SCM_GLUT_CB_, num)); \ + if (!SCM_FALSEP(cb)) { \ + Scm_ApplyRec(cb, args); \ + } \ + } + +define_callback(display, DISPLAY, (void), SCM_NIL) + + +define_callback(overlay_display, OVERLAY_DISPLAY, (void), SCM_NIL) +define_callback(reshape, RESHAPE, (int w, int h), + SCM_LIST2(SCM_MAKE_INT(w), SCM_MAKE_INT(h))); +define_callback(keyboard, KEYBOARD, (unsigned char key, int w, int h), + SCM_LIST3(SCM_MAKE_INT(key), SCM_MAKE_INT(w), SCM_MAKE_INT(h))) +define_callback(keyboard_up, KEYBOARD_UP, (unsigned char key, int w, int h), + SCM_LIST3(SCM_MAKE_INT(key), SCM_MAKE_INT(w), SCM_MAKE_INT(h))) +define_callback(mouse, MOUSE, (int button, int state, int x, int y), + SCM_LIST4(SCM_MAKE_INT(button), SCM_MAKE_INT(state), + SCM_MAKE_INT(x), SCM_MAKE_INT(y))) +define_callback(motion, MOTION, (int x, int y), + SCM_LIST2(SCM_MAKE_INT(x), SCM_MAKE_INT(y))) +define_callback(passive_motion, PASSIVE_MOTION, (int x, int y), + SCM_LIST2(SCM_MAKE_INT(x), SCM_MAKE_INT(y))) +define_callback(visibility, VISIBILITY, (int state), + SCM_LIST1(SCM_MAKE_INT(state))) +define_callback(entry, ENTRY, (int state), + SCM_LIST1(SCM_MAKE_INT(state))) +define_callback(special, SPECIAL, (int key, int w, int h), + SCM_LIST3(SCM_MAKE_INT(key), SCM_MAKE_INT(w), SCM_MAKE_INT(h))) +define_callback(special_up, SPECIAL_UP, (int key, int w, int h), + SCM_LIST3(SCM_MAKE_INT(key), SCM_MAKE_INT(w), SCM_MAKE_INT(h))) +define_callback(spaceball_motion, SPACEBALL_MOTION, (int x, int y, int z), + SCM_LIST3(SCM_MAKE_INT(x), SCM_MAKE_INT(y), SCM_MAKE_INT(z))) +define_callback(spaceball_rotate, SPACEBALL_ROTATE, (int x, int y, int z), + SCM_LIST3(SCM_MAKE_INT(x), SCM_MAKE_INT(y), SCM_MAKE_INT(z))) +define_callback(spaceball_button, SPACEBALL_BUTTON, (int button, int state), + SCM_LIST2(SCM_MAKE_INT(button), SCM_MAKE_INT(state))) +define_callback(button_box, BUTTON_BOX, (int button, int state), + SCM_LIST2(SCM_MAKE_INT(button), SCM_MAKE_INT(state))) +define_callback(dials, DIALS, (int dial, int value), + SCM_LIST2(SCM_MAKE_INT(dial), SCM_MAKE_INT(value))) +define_callback(tablet_motion, TABLET_MOTION, (int x, int y), + SCM_LIST2(SCM_MAKE_INT(x), SCM_MAKE_INT(y))) +define_callback(tablet_button, TABLET_BUTTON, + (int button, int state, int x, int y), + SCM_LIST4(SCM_MAKE_INT(button), + SCM_MAKE_INT(state), + SCM_MAKE_INT(x), + SCM_MAKE_INT(y))) +define_callback(menu_status, MENU_STATUS, (int status, int x, int y), + SCM_LIST3(SCM_MAKE_INT(status), + SCM_MAKE_INT(x), SCM_MAKE_INT(y))) +define_callback(window_status, WINDOW_STATUS, (int status), + SCM_LIST1(SCM_MAKE_INT(status))) +define_callback(joystick, JOYSTICK, (unsigned int mask, int x, int y, int z), + SCM_LIST4(SCM_MAKE_INT(mask), + SCM_MAKE_INT(x), SCM_MAKE_INT(y), SCM_MAKE_INT(z))) + +/* global callbacks */ +static ScmObj idle_closure = SCM_FALSE; + +static void idle_cb(void) +{ + if (!SCM_FALSEP(idle_closure)) { + Scm_ApplyRec(idle_closure, SCM_NIL); + } +} + +static ScmObj timer_closure = SCM_FALSE; + +static void timer_cb(int value) +{ + if (!SCM_FALSEP(timer_closure)) { + Scm_ApplyRec(timer_closure, SCM_LIST1(Scm_MakeInteger(value))); + } +} + + +/* NB: these functions are new addition by freeglut. we provide + dummy functions for older versions. */ +#if !(GLUT_API_VERSION >= 4 || GLUT_XLIB_IMPLEMENTATION >= 13) +static void glutKeyboardUpFunc(void (*fn)(unsigned char, int, int)) +{ + Scm_Warn("glutKeyboardUpFunc unsupported in this version of GLUT"); +} +static void glutSpecialUpFunc(void (*fn)(int, int, int)) +{ + Scm_Warn("glutSpecialUpFunc unsupported in this version of GLUT"); +} +static void glutJoystickFunc(void (*fn)(unsigned int, int, int, int), + int interval) +{ + Scm_Warn("glutJoystickFunc unsupported in this version of GLUT"); +} +static void glutWindowStatusFunc(void (*fn)(unsigned int, int, int, int)) +{ + Scm_Warn("glutWindowStatusFunc unsupported in this version of GLUT"); +} +#endif + + +#define define_registrar(glutfn, cbname) \ + static void SCM_CPP_CAT(register_, cbname)(int flag, int xtra) \ + { \ + if (flag) { \ + glutfn(SCM_CPP_CAT(cbname, _cb)); \ + } else { \ + glutfn(NULL); \ + } \ + } + +define_registrar(glutDisplayFunc, display) +define_registrar(glutOverlayDisplayFunc, overlay_display) +define_registrar(glutReshapeFunc, reshape) +define_registrar(glutKeyboardFunc, keyboard) +define_registrar(glutKeyboardUpFunc, keyboard_up) +define_registrar(glutMouseFunc, mouse) +define_registrar(glutMotionFunc, motion) +define_registrar(glutPassiveMotionFunc, passive_motion) +define_registrar(glutVisibilityFunc, visibility) +define_registrar(glutEntryFunc, entry) +define_registrar(glutSpecialFunc, special) +define_registrar(glutSpecialUpFunc, special_up) +define_registrar(glutSpaceballMotionFunc, spaceball_motion) +define_registrar(glutSpaceballRotateFunc, spaceball_rotate) +define_registrar(glutSpaceballButtonFunc, spaceball_button) +define_registrar(glutButtonBoxFunc, button_box) +define_registrar(glutDialsFunc, dials) +define_registrar(glutTabletMotionFunc, tablet_motion) +define_registrar(glutTabletButtonFunc, tablet_button) +define_registrar(glutMenuStatusFunc, menu_status) +define_registrar(glutWindowStatusFunc, window_status) + +/* joystick fn is a bit different */ +static void register_joystick(int flag, int interval) +{ + if (flag) { + glutJoystickFunc(joystick_cb, interval); + } else { + glutJoystickFunc(NULL, interval); + } +} + + +/* NB: order must match SCM_GLUT_CB_* enums */ +static void (*registrars[])(int flag, int xtra) = { + register_display, + register_overlay_display, + register_reshape, + register_keyboard, + register_mouse, + register_motion, + register_passive_motion, + register_visibility, + register_entry, + register_special, + register_spaceball_motion, + register_spaceball_rotate, + register_spaceball_button, + register_button_box, + register_dials, + register_tablet_motion, + register_tablet_button, + register_menu_status, + register_window_status, + register_keyboard_up, + register_special_up, + register_joystick, +}; + +/* + * External entry to manage registering callbacks + * 'xtra1' and 'xtra2' are ignored by most callbacks; only the two callbacks + * use them: + * glutTimerFunc: xtra1 for millliseconds, xtra2 for value + * glutJoystickFunc: xtra1 for interval + */ +void Scm_GlutRegisterCallback(int type, ScmObj closure, int xtra1, int xtra2) +{ + SCM_ASSERT(type >= 0 && type < SCM_GLUT_NUM_CBS); + if (type < SCM_GLUT_NUM_WINDOW_CBS) { + int win = glutGetWindow(); + ScmObj entry = Scm_HashTableRef(SCM_HASH_TABLE(ScmGlutCallbackTable), + SCM_MAKE_INT(win), SCM_FALSE); + + if (SCM_EQ(entry, SCM_FALSE)) { + entry = Scm_MakeVector(SCM_GLUT_NUM_WINDOW_CBS, SCM_FALSE); + Scm_HashTableSet(SCM_HASH_TABLE(ScmGlutCallbackTable), + SCM_MAKE_INT(win), entry, 0); + } + SCM_VECTOR_ELEMENT(entry, type) = closure; + registrars[type](!SCM_FALSEP(closure), xtra1); + } else if (type == SCM_GLUT_CB_IDLE) { + idle_closure = closure; + if (SCM_FALSEP(closure)) { + glutIdleFunc(NULL); + } else { + glutIdleFunc(idle_cb); + } + } else { + timer_closure = closure; + if (!SCM_FALSEP(closure)) { + glutTimerFunc(xtra1, timer_cb, xtra2); + } + } +} + +/*================================================================ + * Initialization + */ void Scm_Init_libgauche_glut(void) { ScmModule *mod; @@ -44,6 +292,9 @@ mod = SCM_MODULE(SCM_FIND_MODULE("gl.glut", TRUE)); Scm_Init_glut_lib(mod); + /* Callback table */ + ScmGlutCallbackTable = Scm_MakeHashTableSimple(SCM_HASH_EQV, 0); + /* Glut built-in fonts */ #define DEFFONT(name) Scm_DefineConst(mod, SCM_SYMBOL(SCM_INTERN(#name)), makeGlutFont(name)) /* Stroke font constants (use these in GLUT program). */ =================================================================== --- gauche-gl-0.4.4.orig/src/gauche-glut.h (revision 301) +++ gauche-gl-0.4.4/src/gauche-glut.h (working copy) @@ -1,7 +1,7 @@ /* * gauche-glut.h - Gauche GLUT binding * - * Copyright(C) 2001 by Shiro Kawai (shiro@acm.org) + * Copyright (c) 2001-2008 Shiro Kawai * * Permission to use, copy, modify, distribute this software and * accompanying documentation for any purpose is hereby granted, @@ -29,5 +29,43 @@ #define SCM_GLUT_FONT_P(obj) (SCM_XTYPEP(obj, SCM_CLASS_GLUT_FONT)) #define SCM_GLUT_FONT(obj) ((ScmGlutFont*)(obj)) +/* glut callback table */ +enum { + /* per-window callbacks */ + SCM_GLUT_CB_DISPLAY, + SCM_GLUT_CB_OVERLAY_DISPLAY, + SCM_GLUT_CB_RESHAPE, + SCM_GLUT_CB_KEYBOARD, + SCM_GLUT_CB_MOUSE, + SCM_GLUT_CB_MOTION, + SCM_GLUT_CB_PASSIVE_MOTION, + SCM_GLUT_CB_VISIBILITY, + SCM_GLUT_CB_ENTRY, + SCM_GLUT_CB_SPECIAL, + SCM_GLUT_CB_SPACEBALL_MOTION, + SCM_GLUT_CB_SPACEBALL_ROTATE, + SCM_GLUT_CB_SPACEBALL_BUTTON, + SCM_GLUT_CB_BUTTON_BOX, + SCM_GLUT_CB_DIALS, + SCM_GLUT_CB_TABLET_MOTION, + SCM_GLUT_CB_TABLET_BUTTON, + SCM_GLUT_CB_MENU_STATUS, + SCM_GLUT_CB_WINDOW_STATUS, /* freeglut addition (glut API version 4) */ + SCM_GLUT_CB_KEYBOARD_UP, /* freeglut addition (glut API version 4) */ + SCM_GLUT_CB_SPECIAL_UP, /* freeglut addition (glut API version 4) */ + SCM_GLUT_CB_JOYSTICK, /* freeglut addition (glut API version 4) */ + + SCM_GLUT_NUM_WINDOW_CBS, /* marker */ + + /* global callbacks */ + SCM_GLUT_CB_IDLE = SCM_GLUT_NUM_WINDOW_CBS, + SCM_GLUT_CB_TIMER, + + SCM_GLUT_NUM_CBS +}; + +extern void Scm_GlutRegisterCallback(int type, ScmObj closure, + int xtra1, int xtra2); + #endif /*GAUCHE_GLUT_H */ =================================================================== --- gauche-gl-0.4.4.orig/src/gauche-math3d.c (revision 301) +++ gauche-gl-0.4.4/src/gauche-math3d.c (working copy) @@ -1,7 +1,7 @@ /* * gauche-math3d.c - 3D vector and matrix arithmetics * - * Copyright(C) 2002-2003 by Shiro Kawai (shiro@acm.org) + * Copyright (c) 2002-2008 Shiro Kawai * * Permission to use, copy, modify, distribute this software and * accompanying documentation for any purpose is hereby granted, @@ -1224,6 +1224,18 @@ } /* + * Transform a vector/point by quaternion + * calculates qvq* + */ +void Scm_QuatfTransformv(float r[], const float q[], const float v[]) +{ + float qconj[4], s[4]; + SCM_QUATF_CONJUGATEV(qconj, q); + Scm_QuatfMulv(s, q, v); + Scm_QuatfMulv(r, s, qconj); +} + +/* * Interpolation */ void Scm_QuatfSlerp(float r[], const float p[], const float q[], float t) @@ -1246,7 +1258,57 @@ */ +/* + * Vectors -> Quaternion + * Return a quaternion that represents the rotation to rotate V to W. + * NOTE: if V = -W, we can't determine a unique rotation. This routine + * returns #,(quatf e0 e1 e2 e3) where eN is very small number. + * It's caller's responsibility to detect the case. + */ +void Scm_VectorsToQuatfv(float r[], const float v[], const float w[]) +{ + float p[4], c, s2, f; + SCM_VECTOR4F_CROSSV(p, v, w); + c = SCM_VECTOR4F_DOTV(v, w); /* cos(t) */ + s2 = SCM_VECTOR4F_DOTV(p, p); /* sin^2(t) */ + if (s2 > 0) { /* NB: should we consider epsilon? */ + f = sqrtf((1-c) / (2*s2)); /* sin(t/2)/sin(t) sans sign */ + } else { + f = 0.0f; + } + r[0] = f*p[0]; + r[1] = f*p[1]; + r[2] = f*p[2]; + r[3] = sqrtf((1+c)/2); +} +/* + * Axes -> Quaternion + * + * (v1, v2) and (w1,w2) are pair of perpendicular unit vectors. Calculates + * a rotation that transforms v1 to w1 and v2 to w2. + */ +void Scm_AxesToQuatfv(float r[], + const float v1[], + const float v2[], + const float w1[], + const float w2[]) +{ + float q1[4], q2[4], c, t, s2, axis[4], wt[4]; + Scm_VectorsToQuatfv(q1, v1, w1); + Scm_QuatfTransformv(wt, q1, v2); + SCM_VECTOR4F_CROSSV(axis, wt, w2); + SCM_VECTOR4F_NORMALIZEV(axis); + c = SCM_VECTOR4F_DOTV(w2, wt); /* cos(t) */ + if (c < -1.0f) c = -1.0f; + else if (c > 1.0f) c = 1.0f; + t = acosf(c); + s2 = sinf(t/2); + q2[0] = axis[0] * s2; q2[1] = axis[1] * s2; q2[2] = axis[2] * s2; + q2[3] = cosf(t/2); + Scm_QuatfMulv(r, q2, q1); +} + /*============================================================= * Initialization */ =================================================================== --- gauche-gl-0.4.4.orig/src/glut-lib.stub (revision 301) +++ gauche-gl-0.4.4/src/glut-lib.stub (working copy) @@ -1,7 +1,7 @@ ;;; ;;; glut-lib.stub - glue functions for GLUT ;;; -;;; Copyright(C) 2001-2002 by Shiro Kawai (shiro@acm.org) +;;; Copyright (c) 2001-2008 Shiro Kawai ;;; ;;; Permission to use, copy, modify, distribute this software and ;;; accompanying documentation for any purpose is hereby granted, @@ -36,31 +36,21 @@ ;; ;; glut-init -;; Takes list of args instead of C-style argc/argv +;; Takes list of args instead of C-style argc/argv, and returns +;; (possibly modified) args. + (define-cproc glut-init (args) - " - int argc, i; - char **argv; - ScmObj ap; + (body + (let* ((argc :: int (Scm_Length args)) + (argv :: char**)) + (when (< argc 0) (SCM_TYPE_ERROR args "list")) + (set! argv (Scm_ListToCStringArray args TRUE NULL)) + (glutInit (& argc) argv) + (result + (Scm_CStringArrayToList (cast |const char**| argv) argc 0))))) - argc = Scm_Length(args); - if (argc < 0) Scm_Error(\"list expected, but got %S\", args); - argv = SCM_NEW2(char **, argc * sizeof(char*)); - i = 0; - SCM_FOR_EACH(ap, args) { - if (!SCM_STRINGP(SCM_CAR(ap))) { - Scm_Error(\"string expected, but got %S\", SCM_CAR(ap)); - } - argv[i] = Scm_GetString(SCM_STRING(SCM_CAR(ap))); - i++; - } - glutInit(&argc, argv); - SCM_RETURN(Scm_MakeInteger(argc)); - ") - (define-cproc glut-init-display-mode (mode::) - "glutInitDisplayMode(mode); - SCM_RETURN(SCM_UNDEFINED);") + (call "glutInitDisplayMode")) (define-cproc glut-init-display-string (string::) " @@ -70,32 +60,26 @@ SCM_RETURN(SCM_UNDEFINED);") (define-cproc glut-init-window-size (width:: height::) - "glutInitWindowSize(width, height); - SCM_RETURN(SCM_UNDEFINED);") + (call "glutInitWindowSize")) (define-cproc glut-init-window-position (x:: y::) - "glutInitWindowPosition(x, y); - SCM_RETURN(SCM_UNDEFINED);") + (call "glutInitWindowPosition")) (define-cproc glut-main-loop () - "glutMainLoop(); - SCM_RETURN(SCM_UNDEFINED);") + (call "glutMainLoop")) -(define-cproc glut-create-window (name::) - "SCM_RETURN(Scm_MakeInteger(glutCreateWindow(Scm_GetStringConst(name))));") +(define-cproc glut-create-window (name::) + (call "glutCreateWindow")) (define-cproc glut-create-sub-window (win:: x:: y:: width:: height::) - "int win = glutCreateSubWindow(win, x, y, width, height); - SCM_RETURN(Scm_MakeInteger(win));") + (call "glutCreateSubWindow")) (define-cproc glut-destroy-window (win::) - "glutDestroyWindow(win); - SCM_RETURN(SCM_UNDEFINED);") + (call "glutDestroyWindow")) (define-cproc glut-post-redisplay () - "glutPostRedisplay(); - SCM_RETURN(SCM_UNDEFINED);") + (call "glutPostRedisplay")) (define-cproc glut-post-window-redisplay (win::) "#if (GLUT_API_VERSION >= 4 || GLUT_XLIB_IMPLEMENTATION >= 11) @@ -104,51 +88,40 @@ SCM_RETURN(SCM_UNDEFINED);") (define-cproc glut-swap-buffers () - "glutSwapBuffers(); - SCM_RETURN(SCM_UNDEFINED);") + (call "glutSwapBuffers")) (define-cproc glut-get-window () - "SCM_RETURN(Scm_MakeInteger(glutGetWindow()));") + (call "glutGetWindow")) (define-cproc glut-set-window (win::) - "glutSetWindow(win); - SCM_RETURN(SCM_UNDEFINED);") + (call "glutSetWindow")) -(define-cproc glut-set-window-title (title::) - "glutSetWindowTitle(Scm_GetStringConst(title)); - SCM_RETURN(SCM_UNDEFINED);") +(define-cproc glut-set-window-title (title::) + (call "glutSetWindowTitle")) -(define-cproc glut-set-icon-title (title::) - "glutSetIconTitle(Scm_GetStringConst(title)); - SCM_RETURN(SCM_UNDEFINED);") +(define-cproc glut-set-icon-title (title::) + (call "glutSetIconTitle")) (define-cproc glut-position-window (x:: y::) - "glutPositionWindow(x, y); - SCM_RETURN(SCM_UNDEFINED);") + (call "glutPositionWindow")) (define-cproc glut-reshape-window (width:: height::) - "glutReshapeWindow(width, height); - SCM_RETURN(SCM_UNDEFINED);") + (call "glutReshapeWindow")) (define-cproc glut-push-window () - "glutPushWindow(); - SCM_RETURN(SCM_UNDEFINED);") + (call "glutPushWindow")) (define-cproc glut-pop-window () - "glutPopWindow(); - SCM_RETURN(SCM_UNDEFINED);") + (call "glutPopWindow")) (define-cproc glut-iconify-window () - "glutIconifyWindow(); - SCM_RETURN(SCM_UNDEFINED);") + (call "glutIconifyWindow")) (define-cproc glut-show-window () - "glutShowWindow(); - SCM_RETURN(SCM_UNDEFINED);") + (call "glutShowWindow")) (define-cproc glut-hide-window () - "glutHideWindow(); - SCM_RETURN(SCM_UNDEFINED);") + (call "glutHideWindow")) (define-cproc glut-full-screen () "#if (GLUT_API_VERSION >= 3) @@ -288,525 +261,83 @@ ;; Callbacks ;; -;; GLUT callbacks doesn't allow function to carry closure information, -;; hence static variables. +;; Most Glut callbacks are associated to the "current window". +;; Scm_GlutRegisterCallback handles the association. -;; display --------------- -"static ScmObj display_fn = SCM_FALSE; - static void display_callback(void) - { - if (SCM_PROCEDUREP(display_fn)) { - Scm_ApplyRec(display_fn, SCM_NIL); - } - }" - (define-cproc glut-display-func (fn) - " display_fn = fn; - if (SCM_PROCEDUREP(display_fn)) { - glutDisplayFunc(display_callback); - } else { - glutDisplayFunc(NULL); - } - SCM_RETURN(SCM_UNDEFINED);") - -;; reshape --------------- -"static ScmObj reshape_fn = SCM_FALSE; - static void reshape_callback(int w, int h) - { - if (SCM_PROCEDUREP(reshape_fn)) { - Scm_ApplyRec(reshape_fn, SCM_LIST2(SCM_MAKE_INT(w), SCM_MAKE_INT(h))); - } - }" - + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_DISPLAY fn 0 0))) +(define-cproc glut-overlay-display-func (fn) + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_OVERLAY_DISPLAY fn 0 0))) (define-cproc glut-reshape-func (fn) - " reshape_fn = fn; - if (SCM_PROCEDUREP(reshape_fn)) { - glutReshapeFunc(reshape_callback); - } else { - glutReshapeFunc(NULL); - } - SCM_RETURN(SCM_UNDEFINED);") - -;; keyboard --------------- -"static ScmObj keyboard_fn = SCM_FALSE; - static void keyboard_callback(unsigned char key, int x, int y) - { - if (SCM_PROCEDUREP(keyboard_fn)) { - Scm_ApplyRec(keyboard_fn, SCM_LIST3(SCM_MAKE_INT(key), - SCM_MAKE_INT(x), - SCM_MAKE_INT(y))); - } - }" - + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_RESHAPE fn 0 0))) (define-cproc glut-keyboard-func (fn) - " keyboard_fn = fn; - if (SCM_PROCEDUREP(keyboard_fn)) { - glutKeyboardFunc(keyboard_callback); - } else { - glutKeyboardFunc(NULL); - } - SCM_RETURN(SCM_UNDEFINED);") - -;; mouse --------------- -"static ScmObj mouse_fn = SCM_FALSE; - static void mouse_callback(int button, int state, int x, int y) - { - if (SCM_PROCEDUREP(mouse_fn)) { - Scm_ApplyRec(mouse_fn, SCM_LIST4(SCM_MAKE_INT(button), - SCM_MAKE_INT(state), - SCM_MAKE_INT(x), - SCM_MAKE_INT(y))); - } - }" - + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_KEYBOARD fn 0 0))) +(define-cproc glut-keyboard-up-func (fn) + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_KEYBOARD_UP fn 0 0))) (define-cproc glut-mouse-func (fn) - " mouse_fn = fn; - if (SCM_PROCEDUREP(mouse_fn)) { - glutMouseFunc(mouse_callback); - } else { - glutMouseFunc(NULL); - } - SCM_RETURN(SCM_UNDEFINED);") - -;; motion --------------- -"static ScmObj motion_fn = SCM_FALSE; - static void motion_callback(int x, int y) - { - if (SCM_PROCEDUREP(motion_fn)) { - Scm_ApplyRec(motion_fn, SCM_LIST2(SCM_MAKE_INT(x), - SCM_MAKE_INT(y))); - } - }" - + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_MOUSE fn 0 0))) (define-cproc glut-motion-func (fn) - " motion_fn = fn; - if (SCM_PROCEDUREP(motion_fn)) { - glutMotionFunc(motion_callback); - } else { - glutMotionFunc(NULL); - } - SCM_RETURN(SCM_UNDEFINED);") - -;; passiveMotion --------------- -"static ScmObj passive_motion_fn = SCM_FALSE; - static void passive_motion_callback(int x, int y) - { - if (SCM_PROCEDUREP(passive_motion_fn)) { - Scm_ApplyRec(passive_motion_fn, SCM_LIST2(SCM_MAKE_INT(x), - SCM_MAKE_INT(y))); - } - }" - + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_MOTION fn 0 0))) (define-cproc glut-passive-motion-func (fn) - " passive_motion_fn = fn; - if (SCM_PROCEDUREP(passive_motion_fn)) { - glutPassiveMotionFunc(passive_motion_callback); - } else { - glutPassiveMotionFunc(NULL); - } - SCM_RETURN(SCM_UNDEFINED);") - -;; Entry --------------- -"static ScmObj entry_fn = SCM_FALSE; - static void entry_callback(int state) - { - if (SCM_PROCEDUREP(entry_fn)) { - Scm_ApplyRec(entry_fn, SCM_LIST1(SCM_MAKE_INT(state))); - } - }" - -(define-cproc glut-entry-func (fn) - " entry_fn = fn; - if (SCM_PROCEDUREP(entry_fn)) { - glutEntryFunc(entry_callback); - } else { - glutEntryFunc(NULL); - } - SCM_RETURN(SCM_UNDEFINED);") - -;; Visibility --------------- -"static ScmObj visibility_fn = SCM_FALSE; - static void visibility_callback(int state) - { - if (SCM_PROCEDUREP(visibility_fn)) { - Scm_ApplyRec(visibility_fn, SCM_LIST1(SCM_MAKE_INT(state))); - } - }" - + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_PASSIVE_MOTION fn 0 0))) (define-cproc glut-visibility-func (fn) - " visibility_fn = fn; - if (SCM_PROCEDUREP(visibility_fn)) { - glutVisibilityFunc(visibility_callback); - } else { - glutVisibilityFunc(NULL); - } - SCM_RETURN(SCM_UNDEFINED);") - -;; Idle --------------- -"static ScmObj idle_fn = SCM_FALSE; - static void idle_callback(void) - { - if (SCM_PROCEDUREP(idle_fn)) { - Scm_ApplyRec(idle_fn, SCM_NIL); - } - }" - -(define-cproc glut-idle-func (fn) - " idle_fn = fn; - if (SCM_PROCEDUREP(idle_fn)) { - glutIdleFunc(idle_callback); - } else { - glutIdleFunc(NULL); - } - SCM_RETURN(SCM_UNDEFINED);") - -;; Timer --------------- -"/* TODO: glut-timer-func can not use multiple timer entry. This is not correct implementation. */ -static ScmObj timer_fn = SCM_FALSE; - static void timer_callback(int value) - { - if (SCM_PROCEDUREP(timer_fn)) { - Scm_ApplyRec(timer_fn, SCM_LIST1(SCM_MAKE_INT(value))); - } - }" - -(define-cproc glut-timer-func (millis:: fn value::) - " timer_fn = fn; - glutTimerFunc(millis, timer_callback, value); - SCM_RETURN(SCM_UNDEFINED);") - -;; MenuState --------------- -"static ScmObj menu_state_fn = SCM_FALSE; - static void menu_state_callback(int state) - { - if (SCM_PROCEDUREP(menu_state_fn)) { - Scm_ApplyRec(menu_state_fn, SCM_LIST1(SCM_MAKE_INT(state))); - } - }" - -(define-cproc glut-menu-state-func (fn) - " menu_state_fn = fn; - if (SCM_PROCEDUREP(menu_state_fn)) { - glutMenuStateFunc(menu_state_callback); - } else { - glutMenuStateFunc(NULL); - } - SCM_RETURN(SCM_UNDEFINED);") - -;; Special ------------------ -"static ScmObj special_fn = SCM_FALSE; - static void special_callback(int key, int x, int y) - { - if (SCM_PROCEDUREP(special_fn)) { - Scm_ApplyRec(special_fn, SCM_LIST3(SCM_MAKE_INT(key), - SCM_MAKE_INT(x), - SCM_MAKE_INT(y))); - } - }" - + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_VISIBILITY fn 0 0))) +(define-cproc glut-entry-func (fn) + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_ENTRY fn 0 0))) (define-cproc glut-special-func (fn) - " special_fn = fn; - if (SCM_PROCEDUREP(special_fn)) { - glutSpecialFunc(special_callback); - } else { - glutSpecialFunc(NULL); - } - SCM_RETURN(SCM_UNDEFINED);") - -;; SpaceballMotion ----------- -"static ScmObj spaceball_motion_fn = SCM_FALSE; - static void spaceball_motion_callback(int x, int y, int z) - { - if (SCM_PROCEDUREP(spaceball_motion_fn)) { - Scm_ApplyRec(spaceball_motion_fn, SCM_LIST3(SCM_MAKE_INT(x), - SCM_MAKE_INT(y), - SCM_MAKE_INT(z))); - } - }" - + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_SPECIAL fn 0 0))) +(define-cproc glut-special-up-func (fn) + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_SPECIAL_UP fn 0 0))) (define-cproc glut-spaceball-motion-func (fn) - " spaceball_motion_fn = fn; - if (SCM_PROCEDUREP(spaceball_motion_fn)) { - glutSpaceballMotionFunc(spaceball_motion_callback); - } else { - glutSpaceballMotionFunc(NULL); - } - SCM_RETURN(SCM_UNDEFINED);") - -;; SpaceballRotate ---------------------- -"static ScmObj spaceball_rotate_fn = SCM_FALSE; - static void spaceball_rotate_callback(int x, int y, int z) - { - if (SCM_PROCEDUREP(spaceball_rotate_fn)) { - Scm_ApplyRec(spaceball_rotate_fn, SCM_LIST3(SCM_MAKE_INT(x), - SCM_MAKE_INT(y), - SCM_MAKE_INT(z))); - } - }" - + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_SPACEBALL_MOTION fn 0 0))) (define-cproc glut-spaceball-rotate-func (fn) - " spaceball_rotate_fn = fn; - if (SCM_PROCEDUREP(spaceball_rotate_fn)) { - glutSpaceballRotateFunc(spaceball_rotate_callback); - } else { - glutSpaceballRotateFunc(NULL); - } - SCM_RETURN(SCM_UNDEFINED);") - -;; SpaceballButton ---------------------- -"static ScmObj spaceball_button_fn = SCM_FALSE; - static void spaceball_button_callback(int button, int state) - { - if (SCM_PROCEDUREP(spaceball_button_fn)) { - Scm_ApplyRec(spaceball_button_fn, SCM_LIST2(SCM_MAKE_INT(button), - SCM_MAKE_INT(state))); - } - }" - + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_SPACEBALL_ROTATE fn 0 0))) (define-cproc glut-spaceball-button-func (fn) - " spaceball_button_fn = fn; - if (SCM_PROCEDUREP(spaceball_button_fn)) { - glutSpaceballButtonFunc(spaceball_button_callback); - } else { - glutSpaceballButtonFunc(NULL); - } - SCM_RETURN(SCM_UNDEFINED);") - -;; ButtonBox ---------------------------- -"static ScmObj button_box_fn = SCM_FALSE; - static void button_box_callback(int button, int state) - { - if (SCM_PROCEDUREP(button_box_fn)) { - Scm_ApplyRec(button_box_fn, SCM_LIST2(SCM_MAKE_INT(button), - SCM_MAKE_INT(state))); - } - }" - + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_SPACEBALL_BUTTON fn 0 0))) (define-cproc glut-button-box-func (fn) - " button_box_fn = fn; - if (SCM_PROCEDUREP(button_box_fn)) { - glutButtonBoxFunc(button_box_callback); - } else { - glutButtonBoxFunc(NULL); - } - SCM_RETURN(SCM_UNDEFINED);") - -;; Dials ----------------------------------- -"static ScmObj dials_fn = SCM_FALSE; - static void dials_callback(int button, int state) - { - if (SCM_PROCEDUREP(dials_fn)) { - Scm_ApplyRec(dials_fn, SCM_LIST2(SCM_MAKE_INT(button), - SCM_MAKE_INT(state))); - } - }" - -(define-cproc glut-dials-func (fn) - " dials_fn = fn; - if (SCM_PROCEDUREP(dials_fn)) { - glutDialsFunc(dials_callback); - } else { - glutDialsFunc(NULL); - } - SCM_RETURN(SCM_UNDEFINED);") - -;; TabletMotion ------------------------- -"static ScmObj tablet_motion_fn = SCM_FALSE; - static void tablet_motion_callback(int x, int y) - { - if (SCM_PROCEDUREP(tablet_motion_fn)) { - Scm_ApplyRec(tablet_motion_fn, SCM_LIST2(SCM_MAKE_INT(x), - SCM_MAKE_INT(y))); - } - }" - + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_BUTTON_BOX fn 0 0))) +(define-cproc glut-dials (fn) + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_DIALS fn 0 0))) (define-cproc glut-tablet-motion-func (fn) - " tablet_motion_fn = fn; - if (SCM_PROCEDUREP(tablet_motion_fn)) { - glutTabletMotionFunc(tablet_motion_callback); - } else { - glutTabletMotionFunc(NULL); - } - SCM_RETURN(SCM_UNDEFINED);") - -;; TabletButton ------------------------- -"static ScmObj tablet_button_fn = SCM_FALSE; - static void tablet_button_callback(int button, int state, int x, int y) - { - if (SCM_PROCEDUREP(tablet_button_fn)) { - Scm_ApplyRec(tablet_button_fn, SCM_LIST4(SCM_MAKE_INT(button), - SCM_MAKE_INT(state), - SCM_MAKE_INT(x), - SCM_MAKE_INT(y))); - } - }" - + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_TABLET_MOTION fn 0 0))) (define-cproc glut-tablet-button-func (fn) - " tablet_button_fn = fn; - if (SCM_PROCEDUREP(tablet_button_fn)) { - glutTabletButtonFunc(tablet_button_callback); - } else { - glutTabletButtonFunc(NULL); - } - SCM_RETURN(SCM_UNDEFINED);") + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_TABLET_BUTTON fn 0 0))) +(define-cproc glut-menu-status (fn) + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_MENU_STATUS fn 0 0))) +(define-cproc glut-window-status (fn) + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_WINDOW_STATUS fn 0 0))) +(define-cproc glut-joystick-func (fn interval::) + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_JOYSTICK fn interval 0))) -;; MenuStatus ----------------------------- -"static ScmObj menu_status_fn = SCM_FALSE; - static void menu_status_callback(int state, int x, int y) - { - if (SCM_PROCEDUREP(menu_status_fn)) { - Scm_ApplyRec(menu_status_fn, SCM_LIST3(SCM_MAKE_INT(state), - SCM_MAKE_INT(x), - SCM_MAKE_INT(y))); - } - }" +(define-cproc glut-idle-func (fn) + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_IDLE fn 0 0))) +(define-cproc glut-timer-func (millis:: fn value::) + (body (Scm_GlutRegisterCallback SCM_GLUT_CB_TIMER fn millis value))) -(define-cproc glut-menu-status-func (fn) - " menu_status_fn = fn; - if (SCM_PROCEDUREP(menu_status_fn)) { - glutMenuStatusFunc(menu_status_callback); - } else { - glutMenuStatusFunc(NULL); - } - SCM_RETURN(SCM_UNDEFINED);") -;; OverlayDisplay -"static ScmObj overlay_display_fn = SCM_FALSE; - static void overlay_display_callback(void) - { - if (SCM_PROCEDUREP(overlay_display_fn)) { - Scm_ApplyRec(overlay_display_fn, SCM_NIL); - } - }" - -(define-cproc glut-ovelay-display-func (fn) - " overlay_display_fn = fn; - if (SCM_PROCEDUREP(overlay_display_fn)) { - glutOverlayDisplayFunc(overlay_display_callback); - } else { - glutOverlayDisplayFunc(NULL); - } - SCM_RETURN(SCM_UNDEFINED);") - -;; WindowStatus --------------------------------- -"#if (GLUT_API_VERSION >= 4 || GLUT_XLIB_IMPLEMENTATION >= 9) - static ScmObj window_status_fn = SCM_FALSE; - static void window_status_callback(int state) - { - if (SCM_PROCEDUREP(window_status_fn)) { - Scm_ApplyRec(window_status_fn, SCM_LIST1(SCM_MAKE_INT(state))); - } - } -#endif" - -(define-cproc glut-window-status-func (fn) - "#if (GLUT_API_VERSION >= 4 || GLUT_XLIB_IMPLEMENTATION >= 9) - window_status_fn = fn; - if (SCM_PROCEDUREP(window_status_fn)) { - glutWindowStatusFunc(window_status_callback); - } else { - glutWindowStatusFunc(NULL); - } -#endif - SCM_RETURN(SCM_UNDEFINED);") - -;; KeyboardUp ---------------------------- -"#if (GLUT_API_VERSION >= 4 || GLUT_XLIB_IMPLEMENTATION >= 13) - static ScmObj keyboard_up_fn = SCM_FALSE; - static void keyboard_up_callback(unsigned char key, int x, int y) - { - if (SCM_PROCEDUREP(keyboard_up_fn)) { - Scm_ApplyRec(keyboard_up_fn, SCM_LIST3(SCM_MAKE_INT(key), - SCM_MAKE_INT(x), - SCM_MAKE_INT(y))); - } - } -#endif" - -(define-cproc glut-keyboard-up-func (fn) - "#if (GLUT_API_VERSION >= 4 || GLUT_XLIB_IMPLEMENTATION >= 13) - keyboard_up_fn = fn; - if (SCM_PROCEDUREP(keyboard_up_fn)) { - glutKeyboardUpFunc(keyboard_up_callback); - } else { - glutKeyboardUpFunc(NULL); - } -#endif - SCM_RETURN(SCM_UNDEFINED);") - -;; SpecialUp -------------------------------- -"#if (GLUT_API_VERSION >= 4 || GLUT_XLIB_IMPLEMENTATION >= 13) - static ScmObj special_up_fn = SCM_FALSE; - static void special_up_callback(int key, int x, int y) - { - if (SCM_PROCEDUREP(special_up_fn)) { - Scm_ApplyRec(special_up_fn, SCM_LIST3(SCM_MAKE_INT(key), - SCM_MAKE_INT(x), - SCM_MAKE_INT(y))); - } - } -#endif" - -(define-cproc glut-special-up-func (fn) - "#if (GLUT_API_VERSION >= 4 || GLUT_XLIB_IMPLEMENTATION >= 13) - special_up_fn = fn; - if (SCM_PROCEDUREP(special_up_fn)) { - glutSpecialUpFunc(special_up_callback); - } else { - glutSpecialUpFunc(NULL); - } -#endif - SCM_RETURN(SCM_UNDEFINED);") - -;; Joystick ------------------------------------ -"#if (GLUT_API_VERSION >= 4 || GLUT_XLIB_IMPLEMENTATION >= 13) - static ScmObj joystick_fn = SCM_FALSE; - static void joystick_callback(unsigned int mask, int x, int y, int z) - { - if (SCM_PROCEDUREP(joystick_fn)) { - Scm_ApplyRec(joystick_fn, SCM_LIST4(Scm_MakeIntegerFromUI(mask), - SCM_MAKE_INT(x), - SCM_MAKE_INT(y), - SCM_MAKE_INT(z))); - } - } -#endif" - -(define-cproc glut-joystick-func (fn interval::) - "#if (GLUT_API_VERSION >= 4 || GLUT_XLIB_IMPLEMENTATION >= 13) - joystick_fn = fn; - if (SCM_PROCEDUREP(joystick_fn)) { - glutJoystickFunc(joystick_callback, interval); - } else { - glutJoystickFunc(NULL, interval); - } -#endif - SCM_RETURN(SCM_UNDEFINED);") - ;;======================================================== ;; Colormap ;; (define-cproc glut-set-color (index:: r:: g:: b::) - (return "glutSetColor")) + (call "glutSetColor")) (define-cproc glut-get-color (index:: component::) "SCM_RETURN(Scm_MakeFlonum((double)glutGetColor(index, component)));") (define-cproc glut-copy-colormap (win::) - "glutCopyColormap(win); - SCM_RETURN(SCM_UNDEFINED);") + (call "glutCopyColormap")) ;;======================================================== ;; state retrieval ;; (define-cproc glut-get (type::) - "SCM_RETURN(Scm_MakeInteger(glutGet(type)));") + (call "glutGet")) (define-cproc glut-device-get (type::) - "SCM_RETURN(Scm_MakeInteger(glutDeviceGet(type)));") + (call "glutDeviceGet")) (define-cproc glut-extension-supported (name::) "#if (GLUT_API_VERSION >= 2) @@ -871,62 +402,62 @@ ;; (define-cproc glut-wire-sphere (radius:: slices:: stacks::) - (return "glutWireSphere")) + (call "glutWireSphere")) (define-cproc glut-solid-sphere (radius:: slices:: stacks::) - (return "glutSolidSphere")) + (call "glutSolidSphere")) (define-cproc glut-wire-cone (radius:: height:: slices:: stacks::) - (return "glutWireCone")) + (call "glutWireCone")) (define-cproc glut-solid-cone (radius:: height:: slices:: stacks::) - (return "glutSolidCone")) + (call "glutSolidCone")) (define-cproc glut-wire-cube (size::) - (return "glutWireCube")) + (call "glutWireCube")) (define-cproc glut-solid-cube (size::) - (return "glutSolidCube")) + (call "glutSolidCube")) (define-cproc glut-wire-torus (inner:: outer:: sides:: rings::) - (return "glutWireTorus")) + (call "glutWireTorus")) (define-cproc glut-solid-torus (inner:: outer:: sides:: rings::) - (return "glutSolidTorus")) + (call "glutSolidTorus")) (define-cproc glut-wire-dodecahedron () - (return "glutWireDodecahedron")) + (call "glutWireDodecahedron")) (define-cproc glut-solid-dodecahedron () - (return "glutSolidDodecahedron")) + (call "glutSolidDodecahedron")) (define-cproc glut-wire-teapot (size::) - (return "glutWireTeapot")) + (call "glutWireTeapot")) (define-cproc glut-solid-teapot (size::) - (return "glutSolidTeapot")) + (call "glutSolidTeapot")) (define-cproc glut-wire-octahedron () - (return "glutWireOctahedron")) + (call "glutWireOctahedron")) (define-cproc glut-solid-octahedron () - (return "glutSolidOctahedron")) + (call "glutSolidOctahedron")) (define-cproc glut-wire-tetrahedron () - (return "glutWireTetrahedron")) + (call "glutWireTetrahedron")) (define-cproc glut-solid-tetrahedron () - (return "glutSolidTetrahedron")) + (call "glutSolidTetrahedron")) (define-cproc glut-wire-icosahedron () - (return "glutWireIcosahedron")) + (call "glutWireIcosahedron")) (define-cproc glut-solid-icosahedron () - (return "glutSolidIcosahedron")) + (call "glutSolidIcosahedron")) ;;======================================================== ;; Video resize =================================================================== --- gauche-gl-0.4.4.orig/src/gauche/math3d.h (revision 301) +++ gauche-gl-0.4.4/src/gauche/math3d.h (working copy) @@ -1,7 +1,7 @@ /* * gauche/math3d.h - 3D vector and matrix arithmetic * - * Copyright(C) 2002-2003 by Shiro Kawai (shiro@acm.org) + * Copyright (c) 2002-2008 Shiro Kawai * * Permission to use, copy, modify, distribute this software and * accompanying documentation for any purpose is hereby granted, @@ -275,6 +275,14 @@ } \ } while (0) +#define SCM_QUATF_CONJUGATEV(q, p) \ + do { \ + q[0] = -p[0]; \ + q[1] = -p[1]; \ + q[2] = -p[2]; \ + q[3] = p[3]; \ + } while (0) + extern ScmObj Scm_MakeQuatf(float x, float y, float z, float w); extern ScmObj Scm_MakeQuatfv(const float d[4]); extern ScmObj Scm_MakeQuatfvShared(float d[4]); @@ -289,7 +297,6 @@ extern ScmObj Scm_QuatfMul(const ScmQuatf *p, const ScmQuatf *q); extern void Scm_QuatfMulv(float *r, const float *p, const float *q); extern ScmObj Scm_QuatfNormalize(const ScmQuatf *q); -extern ScmObj Scm_QuatfNormalizev(float *q); extern ScmObj Scm_QuatfNormalizeX(ScmQuatf *q); /* q[] must be a unit quaternion */ @@ -298,9 +305,20 @@ /* m[] must be an orthogonal matrix */ extern void Scm_Matrix4fToQuatfv(float *q, const float *m); +/* q[] must be a unit quaternion */ +extern void Scm_QuatfTransformv(float r[], const float q[], const float v[]); + /* p[] and q[] must be unit quaternions */ extern void Scm_QuatfSlerp(float *r, const float *p, const float *q, float t); +/* v[], v1[], v2[], w[], w1[] and w2[] must be unit vectors */ +extern void Scm_VectorsToQuatfv(float *r, const float *v, const float *w); +extern void Scm_AxesToQuatfv(float r[], + const float v1[], + const float v2[], + const float w1[], + const float w2[]); + /*============================================================= * Matrix */ =================================================================== --- gauche-gl-0.4.4.orig/src/math3d-lib.stub (revision 301) +++ gauche-gl-0.4.4/src/math3d-lib.stub (working copy) @@ -1,7 +1,7 @@ ;;; ;;; math3d-lib.stub - 3d vector arithmetics ;;; -;;; Copyright(C) 2002-2003 by Shiro Kawai (shiro@acm.org) +;;; Copyright (c) 2002-2008 Shiro Kawai ;;; ;;; Permission to use, copy, modify, distribute this software and ;;; accompanying documentation for any purpose is hereby granted, @@ -40,19 +40,19 @@ (define-cproc vector4f (x:: y:: z:: &optional (w:: 0.0)) - (return "Scm_MakeVector4f")) + (call "Scm_MakeVector4f")) (define-cproc vector4f? (obj) - (return "SCM_VECTOR4FP")) + (call "SCM_VECTOR4FP")) (define-cproc make-vector4f () "SCM_RETURN(Scm_MakeVector4fv(NULL));") (define-cproc list->vector4f (l::) - (return "Scm_ListToVector4f")) + (call "Scm_ListToVector4f")) (define-cproc vector4f->list (v::) - (return "Scm_Vector4fToList")) + (call "Scm_Vector4fToList")) (define-cproc f32vector->vector4f (v:: &optional (start:: 0)) @@ -86,31 +86,70 @@ (setter vector4f-set!)) (define-cproc vector4f-dot (x:: y::) - (return "Scm_Vector4fDot")) + (call "Scm_Vector4fDot")) (define-cproc vector4f-cross (x:: y::) - (return "Scm_Vector4fCross")) + (call "Scm_Vector4fCross")) +(define-cproc vector4f-norm (v::) + (expr (SCM_VECTOR4F_NORMV (SCM_VECTOR4F_D v)))) + (define-cproc vector4f-normalize (x::) - (return "Scm_Vector4fNormalize")) + (call "Scm_Vector4fNormalize")) (define-cproc vector4f-normalize! (x::) - (return "Scm_Vector4fNormalizeX")) + (call "Scm_Vector4fNormalizeX")) (define-cproc vector4f-add (x:: y::) - (return "Scm_Vector4fAdd")) + (call "Scm_Vector4fAdd")) (define-cproc vector4f-add! (x:: y::) "Scm_Vector4fAddv(SCM_VECTOR4F_D(x), SCM_VECTOR4F_D(x), SCM_VECTOR4F_D(y)); SCM_RETURN(SCM_OBJ(x));") (define-cproc vector4f-sub (x:: y::) - (return "Scm_Vector4fSub")) + (call "Scm_Vector4fSub")) (define-cproc vector4f-sub! (x:: y::) "Scm_Vector4fSubv(SCM_VECTOR4F_D(x), SCM_VECTOR4F_D(x), SCM_VECTOR4F_D(y)); SCM_RETURN(SCM_OBJ(x));") +(define-cise-stmt vec4-eltwise + [(_ stmts ...) + (letrec ((replace (lambda (form i) + (match form + ['_ i] + [(xs ...) (map (cut replace <> i) xs)] + [_ form])))) + `(begin ,@(append-map (lambda (stmt) + (map (cute replace stmt <>) '(0 1 2 3))) + stmts)))]) + +(define-cproc vector4f-mul (x:: f::) + (body + (let* ((|r[4]| :: float)) + (vec4-eltwise (set! (aref r _) (* (SCM_VECTOR4F_REF x _) f))) + (return (Scm_MakeVector4fv r))))) + +(define-cproc vector4f-mul! (x:: f::) + (body + (vec4-eltwise + (set! (SCM_VECTOR4F_REF x _) (* (SCM_VECTOR4F_REF x _) f))) + (return (SCM_OBJ x)))) + +(define-cproc vector4f-div (x:: f::) + (body + (let* ((|r[4]| :: float)) + (vec4-eltwise + (set! (aref r _) (/ (SCM_VECTOR4F_REF x _) f))) + (return (Scm_MakeVector4fv r))))) + +(define-cproc vector4f-div! (x:: f::) + (body + (vec4-eltwise + (set! (SCM_VECTOR4F_REF x _) (/ (SCM_VECTOR4F_REF x _) f))) + (return (SCM_OBJ x)))) + ;; VectorArray -------------------------------------------------- (define-cproc make-vector4f-array (len:: &optional init) @@ -126,13 +165,13 @@ SCM_RETURN(va);") (define-cproc vector4f-array? (obj) - (return "SCM_VECTOR4F_ARRAY_P")) + (call "SCM_VECTOR4F_ARRAY_P")) (define-cproc vector4f-array-length (v::) - (return "SCM_VECTOR4F_ARRAY_SIZE")) + (call "SCM_VECTOR4F_ARRAY_SIZE")) (define-cproc f32vector->vector4f-array/shared (v::) - (return "Scm_MakeVector4fArrayV")) + (call "Scm_MakeVector4fArrayV")) (define-cproc vector4f-array->f32vector (a::) "SCM_RETURN(Scm_MakeF32VectorFromArray(SCM_VECTOR4F_ARRAY_SIZE(a)*4, @@ -140,33 +179,33 @@ (define-cproc vector4f-array-set! (a:: i:: x::) - (return "Scm_Vector4fArraySet")) + (call "Scm_Vector4fArraySet")) (define-cproc vector4f-array-ref (a:: i:: &optional fallback) - (return "Scm_Vector4fArrayRef") + (call "Scm_Vector4fArrayRef") (setter vector4f-array-set!)) (define-cproc vector4f-array-ref/shared (a:: i:: &optional fallback) - (return "Scm_Vector4fArrayRefShared")) + (call "Scm_Vector4fArrayRefShared")) ;; point4f ------------------------------------------------------ (define-cproc point4f (x:: y:: z:: &optional (w:: 1.0)) - (return "Scm_MakePoint4f")) + (call "Scm_MakePoint4f")) (define-cproc point4f? (obj) - (return "SCM_POINT4FP")) + (call "SCM_POINT4FP")) (define-cproc make-point4f () "SCM_RETURN(Scm_MakePoint4fv(NULL));") (define-cproc list->point4f (l::) - (return "Scm_ListToPoint4f")) + (call "Scm_ListToPoint4f")) (define-cproc point4f->list (x::) - (return "Scm_Point4fToList")) + (call "Scm_Point4fToList")) (define-cproc f32vector->point4f (v:: &optional (start:: 0)) "int size = SCM_F32VECTOR_SIZE(v); @@ -194,14 +233,14 @@ (setter point4f-set!)) (define-cproc point4f-add (x:: y::) - (return "Scm_Point4fAdd")) + (call "Scm_Point4fAdd")) (define-cproc point4f-add! (x:: y::) "Scm_Vector4fAddv(SCM_POINT4F_D(x), SCM_POINT4F_D(x), SCM_VECTOR4F_D(y)); SCM_RETURN(SCM_OBJ(x));") (define-cproc point4f-sub (x:: y) - (return "Scm_Point4fSub")) + (call "Scm_Point4fSub")) ;point4f-sub! @@ -220,13 +259,13 @@ SCM_RETURN(va);") (define-cproc point4f-array? (obj) - (return "SCM_POINT4F_ARRAY_P")) + (call "SCM_POINT4F_ARRAY_P")) (define-cproc point4f-array-length (v::) - (return "SCM_POINT4F_ARRAY_SIZE")) + (call "SCM_POINT4F_ARRAY_SIZE")) (define-cproc f32vector->point4f-array/shared (v::) - (return "Scm_MakePoint4fArrayV")) + (call "Scm_MakePoint4fArrayV")) (define-cproc point4f-array->f32vector (a::) "SCM_RETURN(Scm_MakeF32VectorFromArray(SCM_POINT4F_ARRAY_SIZE(a)*4, @@ -235,16 +274,16 @@ (define-cproc point4f-array-set! (a:: i:: x::) - (return "Scm_Point4fArraySet")) + (call "Scm_Point4fArraySet")) (define-cproc point4f-array-ref (a:: i:: &optional fallback) - (return "Scm_Point4fArrayRef") + (call "Scm_Point4fArrayRef") (setter point4f-array-set!)) (define-cproc point4f-array-ref/shared (a:: i:: &optional fallback) - (return "Scm_Point4fArrayRefShared")) + (call "Scm_Point4fArrayRefShared")) ;; Matrix4f ------------------------------------------------------- @@ -258,29 +297,41 @@ SCM_RETURN(Scm_MakeMatrix4fv(SCM_F32VECTOR_ELEMENTS(init)));") (define-cproc matrix4f (&rest args) - (return "Scm_ListToMatrix4f")) + (call "Scm_ListToMatrix4f")) (define-cproc matrix4f? (obj) - (return "SCM_MATRIX4FP")) + (call "SCM_MATRIX4FP")) (define-cproc list->matrix4f (l::) - (return "Scm_ListToMatrix4f")) + (call "Scm_ListToMatrix4f")) (define-cproc matrix4f->list (m::) - (return "Scm_Matrix4fToList")) + (call "Scm_Matrix4fToList")) (define-cproc f32vector->matrix4f (v:: &optional (start:: 0)) - "int size = SCM_F32VECTOR_SIZE(v); - if (start < 0 || size-start < 16) - Scm_Error(\"f32vector too small: %S (start=%d)\", v, start); - SCM_RETURN(Scm_MakeMatrix4fv(SCM_F32VECTOR_ELEMENTS(v)+start));") + (body + (let* ((size :: int (SCM_F32VECTOR_SIZE v))) + (when (or (< start 0) (< (- size start) 16)) + (Scm_Error "f32vector too small: %S (start=%d)" v start)) + (result (Scm_MakeMatrix4fv (+ (SCM_F32VECTOR_ELEMENTS v) start)))))) + +(define-cproc f32vector->matrix4f! (m:: + v:: + &optional (start:: 0)) + (body + (let* ((size :: int (SCM_F32VECTOR_SIZE v))) + (when (or (< start 0) (< (- size start) 16)) + (Scm_Error "f32vector too small: %S (start=%d)" v start)) + (Scm_Matrix4fSetv m (+ (SCM_F32VECTOR_ELEMENTS v) start)) + (result (SCM_OBJ m))))) + (define-cproc matrix4f->f32vector (m::) - "SCM_RETURN(Scm_MakeF32VectorFromArray(16, SCM_MATRIX4F_D(m)));") + (expr (Scm_MakeF32VectorFromArray 16 (SCM_MATRIX4F_D m)))) (define-cproc matrix4f-copy (m::) - "SCM_RETURN(Scm_MakeMatrix4fv(SCM_MATRIX4F_D(m)));") + (expr (Scm_MakeMatrix4fv (SCM_MATRIX4F_D m)))) (define-cproc matrix4f-copy! (dst:: src::) - "SCM_RETURN(Scm_Matrix4fSetv(dst, SCM_MATRIX4F_D(src)));") + (expr (Scm_Matrix4fSetv dst (SCM_MATRIX4F_D src)))) (define-cproc matrix4f-mul (p:: q) "if (SCM_MATRIX4FP(q)) SCM_RETURN(Scm_Matrix4fMulMatrix4f(p, SCM_MATRIX4F(q))); @@ -516,12 +567,27 @@ SCM_VECTOR4F_D(S)); SCM_RETURN(SCM_MAKE_BOOL(r));") +(define-cproc matrix4f->translation (m::) + (body + (result (Scm_MakeVector4f (aref (SCM_MATRIX4F_D m) 12) + (aref (SCM_MATRIX4F_D m) 13) + (aref (SCM_MATRIX4F_D m) 14) + 0.0)))) + +(define-cproc matrix4f->translation! (v:: m::) + (body + (set! (SCM_VECTOR4F_REF v 0) (aref (SCM_MATRIX4F_D m) 12)) + (set! (SCM_VECTOR4F_REF v 1) (aref (SCM_MATRIX4F_D m) 13)) + (set! (SCM_VECTOR4F_REF v 2) (aref (SCM_MATRIX4F_D m) 14)) + (set! (SCM_VECTOR4F_REF v 3) 0.0) + (result (SCM_OBJ v)))) + (define-cproc matrix4f->rotation (m::) "float v[4]; float angle = Scm_Matrix4fToRotationv(SCM_MATRIX4F_D(m), v); SCM_RETURN(Scm_Values2(Scm_MakeVector4fv(v), Scm_MakeFlonum((double)angle)));") -(define-cproc matrix4f->rotation! (m:: v::) +(define-cproc matrix4f->rotation! (v:: m::) "float angle = Scm_Matrix4fToRotationv(SCM_MATRIX4F_D(m), SCM_VECTOR4F_D(v)); SCM_RETURN(Scm_Values2(SCM_OBJ(v), Scm_MakeFlonum((double)angle)));") @@ -529,10 +595,10 @@ ;; Quatf ---------------------------------------------------- (define-cproc quatf (x:: y:: z:: w::) - (return "Scm_MakeQuatf")) + (call "Scm_MakeQuatf")) (define-cproc quatf? (obj) - (return "SCM_QUATFP")) + (call "SCM_QUATFP")) (define-cproc make-quatf (&optional vec (angle:: 0)) "if (SCM_UNBOUNDP(vec)) { @@ -547,9 +613,9 @@ }") (define-cproc list->quatf (x) - (return "Scm_ListToQuatf")) + (call "Scm_ListToQuatf")) (define-cproc quatf->list (q::) - (return "Scm_QuatfToList")) + (call "Scm_QuatfToList")) (define-cproc f32vector->quatf (x:: &optional (start:: 0)) "int size = SCM_F32VECTOR_SIZE(x); @@ -576,6 +642,14 @@ SCM_QUATF_D(q)[i] = (float)val; SCM_RETURN(SCM_OBJ(q));") +(define-cproc quatf-set4! (q:: x:: y:: z:: w::) + (body + (set! (aref (SCM_QUATF_D q) 0) x + (aref (SCM_QUATF_D q) 1) y + (aref (SCM_QUATF_D q) 2) z + (aref (SCM_QUATF_D q) 3) w) + (result (SCM_OBJ q)))) + (define-cproc rotation->quatf! (q:: v angle::) "float *qv = SCM_QUATF_D(q), *vv; double sint, cost; @@ -586,14 +660,14 @@ SCM_RETURN(SCM_OBJ(q));") (define-cproc quatf-add (p:: q::) - (return "Scm_QuatfAdd")) + (call "Scm_QuatfAdd")) (define-cproc quatf-add! (p:: q::) "float r[4]; Scm_QuatfAddv(r, SCM_QUATF_D(p), SCM_QUATF_D(q)); SCM_RETURN(Scm_QuatfSetv(p, r));") (define-cproc quatf-sub (p:: q::) - (return "Scm_QuatfSub")) + (call "Scm_QuatfSub")) (define-cproc quatf-sub! (p:: q::) "float r[4]; Scm_QuatfSubv(r, SCM_QUATF_D(p), SCM_QUATF_D(q)); @@ -610,7 +684,7 @@ SCM_RETURN(SCM_OBJ(q));") (define-cproc quatf-mul (p:: q::) - (return "Scm_QuatfMul")) + (call "Scm_QuatfMul")) (define-cproc quatf-mul! (p:: q::) "float r[4]; Scm_QuatfMulv(r, SCM_QUATF_D(p), SCM_QUATF_D(q)); @@ -618,25 +692,35 @@ ;; calculate qpq* (define-cproc quatf-transform (quat:: v) - "float *d, *q, qconj[4], s[4], r[4]; - SCM_MATH3D_X4FP(d, v); - q = SCM_QUATF_D(quat); - qconj[0] = -q[0]; qconj[1] = -q[1]; qconj[2] = -q[2]; qconj[3] = q[3]; - Scm_QuatfMulv(s, q, d); - Scm_QuatfMulv(r, s, qconj); - if (SCM_VECTOR4FP(v)) SCM_RETURN(Scm_MakeVector4fv(r)); - else if (SCM_POINT4FP(v)) SCM_RETURN(Scm_MakePoint4fv(r)); - else SCM_RETURN(Scm_MakeF32VectorFromArray(4, r));") + (body + (let* ((d :: float*) (|r[4]| :: float)) + (SCM_MATH3D_X4FP d v) + (Scm_QuatfTransformv r (SCM_QUATF_D quat) d) + (cond [(SCM_VECTOR4FP v) (result (Scm_MakeVector4fv r))] + [(SCM_POINT4FP v) (result (Scm_MakePoint4fv r))] + [else (result (Scm_MakeF32VectorFromArray 4 r))])))) (define-cproc quatf-conjugate (q::) - "float *d = SCM_QUATF_D(q); - SCM_RETURN(Scm_MakeQuatf(-d[0], -d[1], -d[2], d[3]));") + (body + (let* ((d :: float* (SCM_QUATF_D q))) + (result (Scm_MakeQuatf (- (aref d 0)) (- (aref d 1)) (- (aref d 2)) + (aref d 3)))))) + +(define-cproc quatf-conjugate! (q:: p::) + (body + (let* ((s :: float* (SCM_QUATF_D p)) + (d :: float* (SCM_QUATF_D q))) + (SCM_QUATF_CONJUGATEV d s) + (result (SCM_OBJ q))))) + (define-cproc quatf-norm (q::) - "SCM_RETURN(Scm_MakeFlonum(SCM_QUATF_NORMV(SCM_QUATF_D(q))));") + (expr (Scm_MakeFlonum (SCM_QUATF_NORMV (SCM_QUATF_D q))))) + (define-cproc quatf-normalize (q::) - (return "Scm_QuatfNormalize")) + (call "Scm_QuatfNormalize")) + (define-cproc quatf-normalize! (q::) - (return "Scm_QuatfNormalizeX")) + (call "Scm_QuatfNormalizeX")) (define-cproc quatf->matrix4f (q::) "float m[16]; @@ -647,21 +731,60 @@ SCM_RETURN(SCM_OBJ(m));") (define-cproc matrix4f->quatf (m::) - "float q[4]; - Scm_Matrix4fToQuatfv(q, SCM_MATRIX4F_D(m)); - SCM_RETURN(Scm_MakeQuatfv(q));") + (body + (let* ((|q[4]| :: float)) + (Scm_Matrix4fToQuatfv q (SCM_MATRIX4F_D m)) + (result (Scm_MakeQuatfv q))))) + (define-cproc matrix4f->quatf! (q:: m::) - "Scm_Matrix4fToQuatfv(SCM_QUATF_D(q), SCM_MATRIX4F_D(m)); - SCM_RETURN(SCM_OBJ(q));") + (body + (Scm_Matrix4fToQuatfv (SCM_QUATF_D q) (SCM_MATRIX4F_D m)) + (result (SCM_OBJ q)))) (define-cproc quatf-slerp (p:: q:: t::) - "float r[4]; - Scm_QuatfSlerp(r, SCM_QUATF_D(q), SCM_QUATF_D(p), t); - SCM_RETURN(Scm_MakeQuatfv(r));") + (body + (let* ((|r[4]| :: float)) + (Scm_QuatfSlerp r (SCM_QUATF_D p) (SCM_QUATF_D q) t) + (result (Scm_MakeQuatfv r))))) + (define-cproc quatf-slerp! (r:: p:: q:: t::) - "Scm_QuatfSlerp(SCM_QUATF_D(r), SCM_QUATF_D(p), SCM_QUATF_D(p), t); - SCM_RETURN(SCM_OBJ(r));") + (body + (Scm_QuatfSlerp (SCM_QUATF_D r) (SCM_QUATF_D p) (SCM_QUATF_D q) t) + (result (SCM_OBJ r)))) +(define-cproc vectors->quatf (v:: w::) + (body + (let* ((|r[4]| :: float)) + (Scm_VectorsToQuatfv r (SCM_VECTOR4F_D v) (SCM_VECTOR4F_D w)) + (result (Scm_MakeQuatfv r))))) + +(define-cproc vectors->quatf! (q:: v:: w::) + (body + (Scm_VectorsToQuatfv (SCM_QUATF_D q) + (SCM_VECTOR4F_D v) (SCM_VECTOR4F_D w)) + (result (SCM_OBJ q)))) + +(define-cproc axes->quatf (v1:: + v2:: + w1:: + w2::) + (body + (let* ((|r[4]| :: float)) + (Scm_AxesToQuatfv r (SCM_VECTOR4F_D v1) (SCM_VECTOR4F_D v2) + (SCM_VECTOR4F_D w1) (SCM_VECTOR4F_D w2)) + (result (Scm_MakeQuatfv r))))) + +(define-cproc axes->quatf! (q:: + v1:: + v2:: + w1:: + w2::) + (body + (Scm_AxesToQuatfv (SCM_QUATF_D q) + (SCM_VECTOR4F_D v1) (SCM_VECTOR4F_D v2) + (SCM_VECTOR4F_D w1) (SCM_VECTOR4F_D w2)) + (result (SCM_OBJ q)))) + ;; Local variables: ;; mode: scheme ;; end: =================================================================== --- gauche-gl-0.4.4.orig/src/glext-lib.stub (revision 301) +++ gauche-gl-0.4.4/src/glext-lib.stub (working copy) @@ -1,7 +1,7 @@ ;;; ;;; glext-lib.stub - glue functions for GL extensions ;;; -;;; Copyright(C) 2004-2005 by Shiro Kawai (shiro@acm.org) +;;; Copyright (c) 2004-2008 Shiro Kawai ;;; ;;; Permission to use, copy, modify, distribute this software and ;;; accompanying documentation for any purpose is hereby granted, @@ -375,15 +375,25 @@ ;; (define-cproc gl-active-texture-arb (texture::) - "ENSURE(glActiveTextureARB); - glActiveTextureARB(texture); - SCM_RETURN(SCM_UNDEFINED);") + (body + "ENSURE(glActiveTextureARB);" + "glActiveTextureARB(texture);")) +(define-cproc gl-active-texture (texture::) ; GL 1.3 + (body + "ENSURE(glActiveTexture);" + "glActiveTexture(texture);")) + (define-cproc gl-client-active-texture-arb (texture::) - "ENSURE(glClientActiveTextureARB); - glClientActiveTextureARB(texture); - SCM_RETURN(SCM_UNDEFINED);") + (body + "ENSURE(glClientActiveTextureARB);" + "glClientActiveTextureARB(texture);")) +(define-cproc gl-client-active-texture (texture::) ; GL 1.3 + (body + "ENSURE(glClientActiveTexture);" + "glClientActiveTexture(texture);")) + (define-cproc gl-multi-tex-coord-arb (texunit:: v &rest args) "if (SCM_F32VECTORP(v)) { switch (SCM_F32VECTOR_SIZE(v)) { @@ -1781,6 +1791,142 @@ ;; GL_NV_vertex_program3 ;; +;;============================================================= +;; GL_EXT_framebuffer_object +;; + +(define-cproc gl-is-renderbuffer-ext (renderbuffer::) + (body + "ENSURE(glIsRenderbufferEXT);" + "SCM_RESULT = glIsRenderbufferEXT(renderbuffer);")) + +(define-cproc gl-bind-renderbuffer-ext (target:: renderbuffer::) + (body + "ENSURE(glBindRenderbufferEXT);" + "glBindRenderbufferEXT(target, renderbuffer);")) + +(define-cproc gl-gen-renderbuffers-ext (size::) + (body "ScmObj vec;" + "ENSURE(glGenRenderbuffersEXT);" + "if (size <= 0) Scm_Error(\"size must be a positive integer, but got %d\", size);" + "vec = Scm_MakeU32Vector(size, 0);" + "glGenRenderbuffersEXT(size, (GLuint*)SCM_U32VECTOR_ELEMENTS(vec));" + "SCM_RESULT = vec;")) + +(define-cproc gl-renderbuffer-storage-ext (target:: + internalformat:: + width:: height::) + (body + "ENSURE(glRenderbufferStorageEXT);" + "glRenderbufferStorageEXT(target, internalformat, width, height);")) + +(define-cproc gl-get-renderbuffer-parameter-ext (target:: + pname::) + (body "GLint val;" + "ENSURE(glGetRenderbufferParameterivEXT);" + "switch (pname) {" + "case GL_RENDERBUFFER_WIDTH_EXT:" + "case GL_RENDERBUFFER_HEIGHT_EXT:" + "case GL_RENDERBUFFER_INTERNAL_FORMAT_EXT:" + "case GL_RENDERBUFFER_RED_SIZE_EXT:" + "case GL_RENDERBUFFER_GREEN_SIZE_EXT:" + "case GL_RENDERBUFFER_BLUE_SIZE_EXT:" + "case GL_RENDERBUFFER_ALPHA_SIZE_EXT:" + "case GL_RENDERBUFFER_DEPTH_SIZE_EXT:" + "case GL_RENDERBUFFER_STENCIL_SIZE_EXT:" + " glGetRenderbufferParameterivEXT(target, pname, &val);" + " SCM_RESULT = Scm_MakeInteger(val);" + " break;" + "default:" + " Scm_Error(\"unsupported pname for gl-get-renderbuffer-parameter-ext: %S\", pname);" + " SCM_RESULT = SCM_UNDEFINED;" + "}")) + +(define-cproc gl-bind-framebuffer-ext (target:: framebuffer::) + (body + "ENSURE(glBindFramebufferEXT);" + "glBindFramebufferEXT(target, framebuffer);")) + +(define-cproc gl-delete-framebuffers-ext (fbs::) + (body + "ENSURE(glDeleteFramebuffersEXT);" + "glDeleteFramebuffersEXT(SCM_U32VECTOR_SIZE(fbs)," + " (GLuint*)SCM_U32VECTOR_ELEMENTS(fbs));")) + +(define-cproc gl-gen-framebuffers-ext (size::) + (body "ScmObj vec;" + "ENSURE(glGenFramebuffersEXT);" + "if (size <= 0) Scm_Error(\"size must be a positive integer, but got %d\", size);" + "vec = Scm_MakeU32Vector(size, 0);" + "glGenFramebuffersEXT(size, (GLuint*)SCM_U32VECTOR_ELEMENTS(vec));" + "SCM_RESULT = vec;")) + +(define-cproc gl-check-framebuffer-status-ext (target::) + (body + "ENSURE(glCheckFramebufferStatusEXT);" + "SCM_RESULT = glCheckFramebufferStatusEXT(target);")) + +(define-cproc gl-framebuffer-texture-1d-ext (target:: + attachment:: + textarget:: + texture:: + level::) + (body + "ENSURE(glFramebufferTexture1DEXT);" + "glFramebufferTexture1DEXT(target, attachment, textarget, texture, level);")) + +(define-cproc gl-framebuffer-texture-2d-ext (target:: + attachment:: + textarget:: + texture:: + level::) + (body + "ENSURE(glFramebufferTexture2DEXT);" + "glFramebufferTexture2DEXT(target, attachment, textarget, texture, level);")) + +(define-cproc gl-framebuffer-texture-3d-ext (target:: + attachment:: + textarget:: + texture:: + level:: + zoffset::) + (body + "ENSURE(glFramebufferTexture3DEXT);" + "glFramebufferTexture3DEXT(target, attachment, textarget, texture, level, zoffset);")) + +(define-cproc gl-framebuffer-renderbuffer-ext (target:: + attachment:: + renderbuffertarget:: + renderbuffer::) + (body + "ENSURE(glFramebufferRenderbufferEXT);" + "glFramebufferRenderbufferEXT(target, attachment, renderbuffertarget, renderbuffer);")) + +(define-cproc gl-get-framebuffer-attachment-parameter-ext (target:: + attachment:: + pname::) + (body "GLint val;" + "ENSURE(glGetFramebufferAttachmentParameterivEXT);" + "switch (pname) {" + "case GL_FRAMEBUFFER_ATTACHMENT_OBJECT_TYPE_EXT:" + "case GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT:" + "case GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LEVEL_EXT:" + "case GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_CUBE_MAP_FACE_EXT:" + "case GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_3D_ZOFFSET_EXT:" + " glGetFramebufferAttachmentParameterivEXT(target, attachment, pname, &val);" + " SCM_RESULT = Scm_MakeInteger(val);" + " break;" + "default:" + " Scm_Error(\"unsupported pname for gl-get-renderbuffer-parameter-ext: %S\", pname);" + " SCM_RESULT = SCM_UNDEFINED;" + "}")) + +(define-cproc gl-generate-mipmap-ext (target::) + (body + "ENSURE(glGenerateMipmapEXT);" + "glGenerateMipmapEXT(target);")) + + ;; Local variables: ;; mode: scheme ;; end: =================================================================== --- gauche-gl-0.4.4.orig/src/glu-lib.stub (revision 301) +++ gauche-gl-0.4.4/src/glu-lib.stub (working copy) @@ -1,7 +1,7 @@ ;;; ;;; glu-lib.stub - glue functions for GLU ;;; -;;; Copyright(C) 2001-2005 by Shiro Kawai (shiro@acm.org) +;;; Copyright (c) 2001-2008 Shiro Kawai ;;; ;;; Permission to use, copy, modify, distribute this software and ;;; accompanying documentation for any purpose is hereby granted, @@ -37,15 +37,15 @@ (define-cproc glu-look-at (eyex:: eyey:: eyez:: ctrx:: ctry:: ctrz:: upx:: upy:: upz::) - (return "gluLookAt")) + (call "gluLookAt")) (define-cproc glu-ortho-2d (left:: right:: bottom:: top::) - (return "gluOrtho2D")) + (call "gluOrtho2D")) (define-cproc glu-perspective (fovy:: aspect:: znear:: zfar::) - (return "gluPerspective")) + (call "gluPerspective")) (define-cproc glu-pick-matrix (x:: y:: w:: h:: vp) "if (!SCM_S32VECTORP(vp) || SCM_S32VECTOR_SIZE(vp) != 4) { =================================================================== --- gauche-gl-0.4.4.orig/src/test-math3d.scm (revision 301) +++ gauche-gl-0.4.4/src/test-math3d.scm (working copy) @@ -9,6 +9,7 @@ (use gl.math3d) (use gauche.sequence) (use math.const) +(use srfi-1) (define (nearly=? a b) (let ((sizea (size-of a)) @@ -56,6 +57,12 @@ (test* "vector4f -" #,(vector4f -1.0 -2.0 -3.0 -4.0) (- #,(vector4f 1.0 2.0 3.0 4.0) #,(vector4f 2.0 4.0 6.0 8.0))) +(test* "vector4f *" #,(vector4f 2 4 6 8) + (* #,(vector4f 1 2 3 4) 2.0)) +(test* "vector4f *" #,(vector4f 2 4 6 8) + (* 2.0 #,(vector4f 1 2 3 4))) +(test* "vector4f /" #,(vector4f 0.5 1.0 1.5 2.0) + (/ #,(vector4f 1 2 3 4) 2.0)) (test* "vector4f dot" 40.0 (vector4f-dot #,(vector4f 1.0 2.0 3.0 4.0) #,(vector4f 2.0 3.0 4.0 5.0))) @@ -69,6 +76,7 @@ (vector4f-normalize! v) v)) + ;; sequence access (test* "sequence" '(1.0 2.0 3.0 4.0) @@ -444,6 +452,31 @@ (* -13 pi/180))) nearly=?) +;; rotation check +(let () + (define (rot-test q v) + (let* ((nv (vector4f-normalize v))) + (test* (format "rotation by quaternion ~s ~s" q v) + (* (quatf->matrix4f q) nv) + (quatf-transform q nv) + nearly=?))) + (define (rot-test* q) + (for-each (cute rot-test (quatf-normalize q) <>) + '(#,(vector4f 1 0 0 0) + #,(vector4f 0 1 0 0) + #,(vector4f 0 0 1 0) + #,(vector4f 1 1 0 0) + #,(vector4f 1 -1 0 0) + #,(vector4f -1 0 1 0) + #,(vector4f 1 0 -1 0) + #,(vector4f 0 1 -1 0) + #,(vector4f 0 -1 1 0) + #,(vector4f 3 1 4 0)))) + (for-each rot-test* + '(#,(quatf 1 0 0 0) #,(quatf 0 1 0 0) #,(quatf 0 0 1 0) + #,(quatf 0 0 0 1) #,(quatf 1 1 1 1) #,(quatf 1 -1 1 -1) + #,(quatf 3 1 -4 5)))) + ;; test case for small trace case (test* "matrix->quatf (small trace)" (make-quatf (vector4f 1 0 0) (- pi 0.1)) @@ -458,6 +491,57 @@ (matrix4f->quatf (rotation->matrix4f (vector4f 0 0 1) (- pi 0.1))) nearly=?) +;; two vectors -> quatf +(let () + (define (2vtest v w) + (let ((nv (vector4f-normalize v)) + (nw (vector4f-normalize w))) + (test* (format "2vtest ~s ~s" v w) nw + (quatf-transform (vectors->quatf nv nw) nv) + nearly=?) + (test* (format "2vtest ~s ~s" w v) nv + (quatf-transform (vectors->quatf nw nv) nw) + nearly=?))) + (2vtest #,(vector4f 1 0 0 0) #,(vector4f 0 1 0 0)) + (2vtest #,(vector4f 0 1 0 0) #,(vector4f 0 0 1 0)) + (2vtest #,(vector4f 0 0 1 0) #,(vector4f 1 0 0 0)) + (2vtest #,(vector4f 1 2 3 0) #,(vector4f 4 -5 6 0)) + (2vtest #,(vector4f 1 1 0 0) #,(vector4f 1 1 0 0)) + (2vtest #,(vector4f 1 1 0 0) #,(vector4f 1 1 0.001 0)) + ) + +;; four vectors -> quatf +(let () + (define (4vtest v1 v2 w1 w2) + (let ((nv1 (vector4f-normalize v1)) + (nv2 (vector4f-normalize v2)) + (nw1 (vector4f-normalize w1)) + (nw2 (vector4f-normalize w2))) + (test* (format "4vtest (~s ~s) (~s ~s)" v1 v2 w1 w2) + (list '(1.0) nw1 nw2 (+ nw1 nw2)) + (let1 q (axes->quatf nv1 nv2 nw1 nw2) + (list (list (quatf-norm q)) + (quatf-transform q nv1) + (quatf-transform q nv2) + (quatf-transform q (+ nv1 nv2)))) + (cut every nearly=? <> <>)) + (test* (format "4vtest (~s ~s) (~s ~s)" w1 w2 v1 v2) + (list '(1.0) nv1 nv2 (+ nv1 nv2)) + (let1 q (axes->quatf nw1 nw2 nv1 nv2) + (list (list (quatf-norm q)) + (quatf-transform q nw1) + (quatf-transform q nw2) + (quatf-transform q (+ nw1 nw2)))) + (cut every nearly=? <> <>)))) + + (4vtest #,(vector4f 1 0 0 0) #,(vector4f 0 1 0 0) + #,(vector4f 0 1 0 0) #,(vector4f 0 0 1 0)) + (4vtest #,(vector4f 1 0 0 0) #,(vector4f 0 1 0 0) + #,(vector4f 0 0 -1 0) #,(vector4f 0 1 0 0)) + (4vtest #,(vector4f 1 1 0 0) #,(vector4f 1 -1 0) + #,(vector4f 1 0 0) #,(vector4f 0 0 1 0)) + ) + ;; sequence access (test* "sequence" '(1.0 2.0 3.0 4.0) =================================================================== --- gauche-gl-0.4.4.orig/doc/Makefile.in (revision 301) +++ gauche-gl-0.4.4/doc/Makefile.in (working copy) @@ -63,7 +63,7 @@ gosh ./extract -en -o gauche-gl-refe.texi gauche-gl-ref.texi gauche-gl-refe.info.gz : gauche-gl-refe.texi - if test X$(MAKEINFO) != X -a X$(GZIP_PROGRAM) != X; then \ + if test "X$(MAKEINFO)" != X -a "X$(GZIP_PROGRAM)" != X; then \ $(MAKEINFO) --no-warn gauche-gl-refe.texi; \ rm -rf gauche-gl-refe.info*.gz; \ $(GZIP_PROGRAM) gauche-gl-refe.info; \ @@ -85,7 +85,7 @@ gosh ./extract -jp -o gauche-gl-refj.texi gauche-gl-ref.texi gauche-gl-refj.info.gz : gauche-gl-refj.texi - if test X$(MAKEINFO) != X -a X$(GZIP_PROGRAM) != X; then \ + if test "X$(MAKEINFO)" != X -a "X$(GZIP_PROGRAM)" != X; then \ $(MAKEINFO) --no-warn gauche-gl-refj.texi; \ rm -rf gauche-gl-refj.info*.gz; \ $(GZIP_PROGRAM) gauche-gl-refj.info ; \ =================================================================== --- gauche-gl-0.4.4.orig/doc/gauche-gl-ref.texi (revision 301) +++ gauche-gl-0.4.4/doc/gauche-gl-ref.texi (working copy) @@ -59,7 +59,7 @@ * OpenGL API:: * GLUT API:: * Vectors and matrices:: -* Simple image handling:: +* Simple utilities:: * Indices:: @end menu @@ -84,13 +84,12 @@ The vector and matrix objects here can be directly passed to Gauche-gl functions. The functions are descrbied in @ref{Vectors and matrices}. -@item gl.simple-image -OpenGL doesn't provide any means of reading/writing image data, and -it should be covered by other Gauche extensions. However, -it is sometimes handy to have simple means to handle external -image data, so that you can do some experiment with Gauche-gl alone. -This module provides minimal support for that. -The functions are descrbied in @ref{Simple image handling}. +@item gl.simple.* +These modules provide simple APIs for programmers to +hack up a very simple OpenGL application. They are by no +means intended for general application development, but +would be handy for throwaway script. +See @ref{Simple utilities} for the details. @end table @c ====================================================================== @@ -2918,7 +2917,7 @@ @c ====================================================================== -@node Vectors and matrices, Simple image handling, GLUT API, Top +@node Vectors and matrices, Simple utilities, GLUT API, Top @chapter Vectors and matrices @deftp {Module} gl.math3d @@ -3115,6 +3114,10 @@ (@var{w} element is ignored). @end defun +@defun vector4f-norm v +Returns the norm (length) of the vector @var{v}. +@end defun + @defun vector4f-normalize x @defunx vector4f-normalize! x Returns a normalized vector of vector4f @var{x}. @@ -3339,6 +3342,12 @@ initial values. The f32vector @var{v} must have enough length. @end defun +@defun f32vector->matrix4f! m v &optional (start 0) +Extract 16 flonums in the f32vector @var{v} starting from the +index @var{start}, and fill the matrix4f @var{m} with them. +The f32vector @var{v} must have enough length. +@end defun + @defun matrix4f->f32vector m Returns a new f32vector that has elements from matrix4f @var{m}. @end defun @@ -3468,8 +3477,8 @@ @xref{Quaternions}, for more details about quaternions. @end defun -@defun euler-angle->matrxi4f xangle yangle zangle &optional order -@defunx euler-angle->matrxi4f! m xangle yangle zangle &optional order +@defun euler-angle->matrix4f xangle yangle zangle &optional order +@defunx euler-angle->matrix4f! m xangle yangle zangle &optional order Returns a matrix that represents rotation along x, y and z axis by @var{xangle}, @var{yangle}, and @var{zangle}, respectively. @@ -3526,12 +3535,23 @@ @var{m} is non-singular or not. @end defun +@defun matrix4f->translation m +Extract the translation component from the given TRS matrix @var{m} +and returns it as a @code{}. +@end defun + +@defun matrix4f->translation! v m +Extract the translation component from the given TRS matrix @var{m} +and stores the result into a @code{} @var{v}. +Returns @var{v}. +@end defun + @defun matrix4f->rotation m From given orthogonal matrix @var{m}, extracts and returns and rotation axis and angle, as a vector4f and a real number. @end defun -@defun matrix4f->rotation! m v +@defun matrix4f->rotation! v m Same as above, except the storage of vector4f @var{v} is reused to store the result axis. @end defun @@ -3607,6 +3627,25 @@ a f32vector (only first three component is used). @end defun +@defun vectors->quatf v w +@defunx vectors->quatf! q v w +Given two unit vectors @var{v} and @var{w}, calculates and returns +a quaternion that represents a rotation from @var{v} to @var{w}. +The destructive version @code{vectors->quatf!} modifies @var{q}. +@end defun + +@defun axes->quatf v1 v2 w1 w2 +@defunx axes->quatf! q v1 v2 w1 w2 +The arguments must be all unit vectors, +@var{v1} and @var{v2} must be perpendicular, +and also @var{w1} and @var{w2} must be perpendicular. + +Calculates and returns a quaternion that represents a rotation +which transforms @var{v1} to @var{w1}, and @var{v2} to @var{w2}, +respectively. The destructive version stores the result +into @var{q}. +@end defun + @defun quatf-add p q @defunx quatf-add! p q @defunx quatf-sub p q @@ -3624,11 +3663,13 @@ @defun quatf-mul p q @defunx quatf-mul! p q Multiply two quaternions @var{p} and @var{q}. -The destructive version modifies @var{p}. +The destructive version modifies @var{p} as well. @end defun -@defun quatf-conjugate q -Returns a conjugate of a quaternion @var{q}. +@defun quatf-conjugate p +@defunx quatf-conjugate! q p +Returns a conjugate of a quaternion @var{p}. +The destructive version modifies @var{q} as well. @end defun @defun quatf-transform q p @@ -3660,22 +3701,47 @@ The destructive version modifies @var{m}. @end defun +@defun matrix4f->quatf m +@defunx matrix4f->quatf! q m +Extracts the rotation component of a matrix @var{m} and +returns a quaterion that represents the rotation. +@code{Matrix4f->quatf!} also uses @var{q} as the storage +to store the result. +@end defun + @defun quatf-slerp p q t @defunx quatf-slerp! r p q t Returns a quaternion that interpolates between two unit quaternions @var{p} and @var{q}, by a scalar value @var{t}. -The destructive version modifies @var{t}. +The destructive version modifies @var{r}. @end defun +@c ====================================================================== +@node Simple utilities, Indices, Vectors and matrices, Top +@chapter Simple utilities +This chapter covers @code{gl.simple.*} modules. They are +provided for the convenience of those who wants quick experiment +with Gauche-gl alone, without a hassle to install a bunch of +other modules. Their features are pretty limited, but you +may find them handy when you need to hack up some throwaway +script that need to show some graphics on the screen. +@menu +* Simple image handling:: +* Simple viewer:: +@end menu -@c ====================================================================== -@node Simple image handling, Indices, Vectors and matrices, Top -@chapter Simple image handling +@node Simple image handling, Simple viewer, Simple utilities, Simple utilities +@section Simple image handling -@deftp {Module} gl.simple-image -@mdindex gl.simple-image +@deftp {Module} gl.simple.image +@mdindex gl.simple.image +OpenGL doesn't provide any means of reading/writing image data, and +it should be covered by other Gauche extensions. However, +it is sometimes handy to have simple means to handle external +image data, so that you can do some experiment with Gauche-gl alone. + This module provides a minimal support to handle external image data, so that one can do some experiment in Gauche-gl alone. @@ -3704,10 +3770,140 @@ for the REPL to display the entire result. @end defun +@node Simple viewer, , Simple image handling, Simple utilities +@section Simple viewer +@deftp {Module} gl.simple.viewer +@mdindex gl.simple.viewer +This module packages common operations to allow users to +view 3D objects, controlling the camera by the mouse, +and have some interactions with the keyboard. +A typical way of using the viewer is like the following: + +@example +(use gl) +(use gl.glut) +(use gl.simple.viewer) + +(define (main args) + (glut-init args) + (simple-viewer-display ) + (simple-viewer-set-key! ...) + (simple-viewer-window :title ...) + (simple-viewer-run) ; loop forever. type ESC to exit. + 0) +@end example + +The viewer handles mouse drag (to move the camera), +and also draws reference grid and axes by default for +your convenience. You have to provide a thunk, which +must draw your 3D object. + +For the keyboard events, you can use a convenient API +to associate handler to the key (character for normal keys, +and constants like @code{GL_LEFT_ARROW} for special keys). + +The reshape event is handled implicitly, though you can +override it. + +If you call @code{simple-viewer-run}, it enters the event +loop and never returns. If you wish to keep REPL and/or +other parts of your application run concurrently, +the convenient way is to run @code{simple-viewer-run} +in a separate thread. + +@example +(use gauche.threads) + +(define (run-viewer) + (thread-start! (make-thread simple-viewer-run #f))) +@end example + +See also the code under @file{examples/simple} directory +of the source tree for more examples. +@end deftp + +@defun simple-viewer-window name &key title mode parent width height x y +Creates a new GL window with @var{name}, which must be a symbol +to identify the window later in the simple viewer framework. +The window won't be shown until @code{simple-viewer-run} is called. + +Each window +@end defun + + +@defun simple-viewer-display &optional display-thunk +Gets/sets the display thunk, which is called every time +the GL window is redrawn. You can change the display thunk +any time, even while the viewer thread is running. + +If no argument is given, returns the current display thunk. +It can be @code{#f} if no display thunk is set. + +When the display thunk is called, the matrix mode is +@code{MODELVIEW} and the camera transformation is already applied. +The grid and axes are also drawn, unless you've customized them. + +In the display thunk you can just write your model in the +world coordinate system. It is guaranteed that +the current color is white and line width is 1.0, but +the states of other GL contexts are undefined, +so you have to set them explicitly. +@end defun + +@defun simple-viewer-reshape &optional reshape-proc +Gets/sets the reshape procedure which is called every +time the GL window configuration is changed. (It is +also called when the GL window is shown first time.) +You can change the reshape procedure any time, +even while the viewer thread is running. + +If no argument is given, returns the current reshape proc. + +A reshape procedure is called with two arguments, +the width and the height (in pixels) of the new GL +window configuration. By default, @code{gl.simple.viewer} +sets a procedure that changes viewport and +projection matrix apopropriately; you need to change +it only if you want a different behavior. +@end defun + +@defun simple-viewer-grid &optional grid-proc +@defunx simple-viewer-axis &optional axis-proc +Gets/sets a procedure to draw a grid and axes. +You can change these procedures +any time, even while the viewer thread is running. + +The @var{grid-proc} and @var{axis-proc} are called with no arguments +every time the GL window is redrawn, before the display thunk +is invoked. +The matrix mode is @code{MODELVIEW}, the camera transformation +is already applied, and lighting is disabled. + +The default grid proc draws 10x10 grid +on X-Z plane centered at the origin. The default axis proc +draws a red line from origin to +X, a green line from origin to +Y, +and a blue line from origin to +Z. + +You can pass @code{#f} to disable grid and/or axis display. + +If no argument is given, returns the current grid/axis proc, +respectively. +@end defun + +@defun simple-viewer-set-key! key handler @dots{} +Even number of arguments must be given; the first of +every two specifies the key, and the next one +specifies the action when the key is pressed. +@end defun + + + + + @c ====================================================================== -@node Indices, , Simple image handling, Top +@node Indices, , Simple utilities, Top @appendix Indices @c NODE º÷°ú =================================================================== --- gauche-gl-0.4.4.orig/lib/Makefile.in (revision 301) +++ gauche-gl-0.4.4/lib/Makefile.in (working copy) @@ -14,7 +14,9 @@ SCMFILES = gl.scm \ gl/math3d.scm \ gl/glut.scm \ - gl/simple-image.scm + gl/simple-image.scm \ + gl/simple/viewer.scm \ + gl/simple/image.scm CONFIG_GENERATED = Makefile =================================================================== --- gauche-gl-0.4.4.orig/lib/gl/simple/viewer.scm (revision 0) +++ gauche-gl-0.4.4/lib/gl/simple/viewer.scm (revision 7080) @@ -0,0 +1,335 @@ +;;; +;;; simple/viewer.scm - simple viewer +;;; +;;; Copyright (c) 2008 Shiro Kawai <shiro@acm.org> +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; +;;; 2. 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. +;;; +;;; 3. Neither the name of the authors 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. +;;; + +;; This is a simple viewer skeleton. It is by no means intended for +;; general applications; it's rather a handy tool to quickly hack up +;; a throwaway script to visualize some data. + +(define-module gl.simple.viewer + (use gl) + (use gl.glut) + (use gl.math3d) + (use util.match) + (use util.list) + (use srfi-42) + (export simple-viewer-window + simple-viewer-set-window + simple-viewer-get-window + simple-viewer-display + simple-viewer-reshape + simple-viewer-grid + simple-viewer-axis + simple-viewer-set-key! + simple-viewer-run + ) + ) +(select-module gl.simple.viewer) + +(define *default-key-handlers* (make-hash-table 'eqv?)) +(define *default-display-proc* #f) +(define *default-grid-proc* (lambda () (default-grid))) +(define *default-axis-proc* (lambda () (default-axis))) +(define *default-reshape-proc* (lambda (w h) (default-reshape w h))) + +;;============================================================= +;; Wrapper of GLUT window +;; + +;; We internally maintain <simple-viewer-window> instance to manage +;; GLUT windows created by simple viewer. However, we only expose +;; window names (symbols) to the users. + +(define-class <simple-viewer-window> () + (;; all slots private. use API. + (name :init-keyword :name) ; window name (symbol) + (id :init-keyword :id) ; GLUT window id + (parent :init-keyword :parent) ; parent window, if this is sub + (closure :init-keyword :closure) ; a closure to maintain the + ; internal state. + (name-tab :allocation :class ; name -> window + :init-form (make-hash-table 'eq?)) + (id-tab :allocation :class ; id -> window + :init-form (make-hash-table 'eqv?)) + )) + +(define-method initialize ((win <simple-viewer-window>) args) + (next-method) + (hash-table-put! (ref win'name-tab) (ref win'name) win) + (hash-table-put! (ref win'id-tab) (ref win'id) win)) + +(define (name->window name) + (hash-table-get (class-slot-ref <simple-viewer-window> 'name-tab) name #f)) +(define (id->window id) + (hash-table-get (class-slot-ref <simple-viewer-window> 'id-tab) id #f)) +(define (name->window-id name) + (and-let* [(win (name->window name))] (ref win'id))) +(define (id->window-name id) + (and-let* [(win (id->window id))] (ref win'name))) + +;; Creates a GL window. +(define (simple-viewer-window name . keys) + (let-keywords keys ((parent #f) + (mode (logior GLUT_DOUBLE GLUT_DEPTH GLUT_RGB)) + (title (x->string name)) + (width 300) + (height 300) + (x #f) + (y #f)) + ;; Internal state + (define prev-x -1) + (define prev-y -1) + (define prev-b #f) + (define rotx 20.0) + (define roty -30.0) + (define rotz 0.0) + (define xlatx 0.0) + (define xlaty 0.0) + (define zoom 1.0) + + (define key-handlers (%hash-table-copy *default-key-handlers*)) + (define grid-proc *default-grid-proc*) + (define axis-proc *default-axis-proc*) + (define display-proc *default-display-proc*) + (define reshape-proc *default-reshape-proc*) + + ;; Callback closures + (define (display-fn) + (gl-clear (logior GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT)) + (gl-push-matrix) + (gl-scale zoom zoom zoom) + (gl-translate xlatx xlaty 0.0) + (gl-rotate rotx 1.0 0.0 0.0) + (gl-rotate roty 0.0 1.0 0.0) + (gl-rotate rotz 0.0 0.0 1.0) + + (gl-disable GL_LIGHTING) + (and grid-proc (grid-proc)) + (and axis-proc (axis-proc)) + (gl-color 1.0 1.0 1.0 0.0) + (gl-line-width 1.0) + (and display-proc (display-proc)) + (gl-pop-matrix) + (glut-swap-buffers)) + + (define (reshape-fn w h) + (set! height h) (set! width w) + (and reshape-proc (reshape-proc w h))) + + (define (mouse-fn button state x y) + (cond [(= state GLUT_UP) + (set! prev-x -1) (set! prev-y -1) (set! prev-b #f)] + [else + (set! prev-x x) (set! prev-y y) (set! prev-b button)])) + + (define (motion-fn x y) + (cond [(= prev-b GLUT_LEFT_BUTTON) + (inc! rotx (* (/. (- y prev-y) height) 90.0)) + (inc! roty (* (/. (- x prev-x) width) 90.0))] + [(= prev-b GLUT_MIDDLE_BUTTON) + (inc! xlatx (* (/. (- x prev-x) width (sqrt zoom)) 12.0)) + (inc! xlaty (* (/. (- prev-y y) height (sqrt zoom)) 12.0))] + [(= prev-b GLUT_RIGHT_BUTTON) + (set! zoom (clamp (* (+ 1.0 (* (/. (- prev-y y) height) 2.0)) + zoom) + 0.1 1000.0))]) + (set! prev-x x) (set! prev-y y) + (glut-post-redisplay)) + + (define (keyboard-fn key x y) + (common-keyboard-func key-handlers key x y)) + (define (special-fn key x y) + (common-special-func key-handlers key x y)) + + (define (closure . args) + (match args + [('grid proc) (set! grid-proc proc)] + [('axis proc) (set! axis-proc proc)] + [('display proc) (set! display-proc proc)] + [('reshape proc) (set! reshape-proc proc)] + [('key-handlers) key-handlers] + [_ (error "unrecognized simple-viewer-window message:" args)])) + + (glut-init-display-mode mode) + ;; Register GLUT window id. + (let* ((pwin (and parent (name->window parent))) + (id (cond [pwin + (glut-create-sub-window (ref pwin'id ) + (or x 0) (or y 0) + width height)] + [else + (glut-init-window-size width height) + (when (and x y) + (glut-init-window-position x y)) + (glut-create-window title)]))) + (make <simple-viewer-window> + :name name :id id :parent pwin :closure closure)) + + ;; Set up handlers. + (glut-display-func display-fn) + (glut-reshape-func reshape-fn) + (glut-mouse-func mouse-fn) + (glut-motion-func motion-fn) + (glut-keyboard-func keyboard-fn) + (glut-special-func special-fn) + + ;; Enable some commonly used stuff + ;; TODO: make them customizable + (gl-enable GL_CULL_FACE) + (gl-enable GL_DEPTH_TEST) + (gl-enable GL_NORMALIZE) + + name)) + +(define (simple-viewer-get-window) + (id->window-name (glut-get-window))) + +(define (simple-viewer-set-window name) + (cond [(name->window-id name) => glut-set-window])) + +;; Callback registrar. +(define-syntax define-registrar + (syntax-rules () + [(_ varname key default-var) + (define (varname proc . opts) + (match opts + [() (set! default-var proc)] + [(name) + (cond [(name->window name) => (lambda (win) + (ref win'closure) 'key proc)] + [else + (errorf "~a: no such window with name: ~a" 'varname name)])] + ))])) + +(define-registrar simple-viewer-display display *default-display-proc*) +(define-registrar simple-viewer-reshape reshape *default-reshape-proc*) +(define-registrar simple-viewer-grid grid *default-grid-proc*) +(define-registrar simple-viewer-axis axis *default-axis-proc*) + +(define (simple-viewer-set-key! window . args) + (let1 tab (cond [(not window) *default-key-handlers*] + [(name->window window) => (cut ref <> 'key-handlers)] + [else + (error "simple-viewer-set-key!: no such window:" window)]) + (let loop ((args args)) + (match args + [() '()] + [(key proc . rest) + (if proc + (hash-table-put! tab key proc) + (hash-table-delete! tab key)) + (loop rest)] + [else '()])))) + +(define (simple-viewer-run . keys) + (let-keywords keys ((rescue-errors #t) + ) + (if rescue-errors + (let1 eport (current-error-port) + (let loop () + (guard (e [else (format eport "*** SIMPLE-VIEWER: ~a\n" + (ref e'message))]) + (glut-main-loop)) + (loop))) + (glut-main-loop)) + )) + +;; +;; Default handlers (private) +;; + +(define (default-reshape w h) + (let1 ratio (/ h w) + (gl-viewport 0 0 w h) + (gl-matrix-mode GL_PROJECTION) + (gl-load-identity) + (gl-frustum -1.0 1.0 (- ratio) ratio 5.0 10000.0) + (gl-matrix-mode GL_MODELVIEW) + (gl-load-identity) + (gl-translate 0.0 0.0 -40.0) + )) + +(define (default-grid) + (gl-color 0.5 0.5 0.5 0.0) + (gl-line-width 1.0) + (gl-begin* GL_LINES + (do-ec (: i -5 6) + (begin + (gl-vertex i 0 -5) + (gl-vertex i 0 5) + (gl-vertex -5 0 i) + (gl-vertex 5 0 i))))) + +(define (default-axis) + (define (axis a b c) + (gl-color a b c 0.0) + (gl-begin* GL_LINES + (gl-vertex 0 0 0) + (gl-vertex a b c))) + (gl-line-width 3.0) + (axis 1.0 0.0 0.0) + (axis 0.0 1.0 0.0) + (axis 0.0 0.0 1.0)) + +(define (quit-loop) + (cond-expand + [gauche.sys.pthreads (thread-terminate! (current-thread))] + [else (exit)])) + +;; common key handler +(define (common-keyboard-func table keycode x y) + (cond [(hash-table-get table (integer->char keycode) #f) + => (cut <> x y)]) + (glut-post-redisplay)) + +(define (common-special-func table keycode x y) + (cond [(hash-table-get table keycode #f) => (cut <> x y)]) + (glut-post-redisplay)) + +;; +;; Set up default keymaps +;; + +(simple-viewer-set-key! #f #\escape (lambda _ (quit-loop))) + +;; oops, Gauche 0.8.13 is missing hash-table-copy. This is a workaround. + +(define %hash-table-copy + (global-variable-ref (find-module 'gauche) 'hash-table-copy + (lambda (src) + (rlet1 dst (make-hash-table (hash-table-type src)) + (hash-table-for-each src + (lambda (k v) + (hash-table-put! dst k v))))) + )) + +(provide "gl/simple/viewer") =================================================================== --- gauche-gl-0.4.4.orig/lib/gl/simple/image.scm (revision 0) +++ gauche-gl-0.4.4/lib/gl/simple/image.scm (revision 7080) @@ -0,0 +1,128 @@ +;;; +;;; gl.simple.image - simple image I/O +;;; +;;; Copyright (c) 2005-2008 Shiro Kawai <shiro@acm.org> +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; +;;; 2. 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. +;;; +;;; 3. Neither the name of the authors 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: simple-image.scm,v 1.2 2008-06-04 11:46:27 shirok Exp $ +;;; + +;; For serious image handling, I'd recommend you to use a serious +;; library (Gauche's GD binding sounds nice, though there's no working +;; version yet). This module provides a minimal routines to do +;; some experiment and testing with Gauche-gl alone. + +(define-module gl.simple.image + (export read-sgi-image read-sgi-image-from-port) + (use gauche.uvector) + (use gauche.sequence) + (use util.match) + (use binary.pack) + (use srfi-42) + ) +(select-module gl.simple.image) + +(define (read-sgi-image file) + (call-with-input-file file read-sgi-image-from-port)) + +;; read-sgi-image-from-port :: port -> (width, height, nchannels, data) +(define (read-sgi-image-from-port port) + (match-let1 (magic compr bpp dim x y z min max pad1 name cmap . pad2) + (unpack "nccnnnnNNNA80Nc404" :input port) + (and (= magic 474) + (= bpp 1) ;; we only support 8bit/channel for now. + (= cmap 0) ;; we only support direct pixel values for now. + (if (= compr 1) + (read-sgi-rle port dim x y z) + (read-sgi-raw port dim x y z))))) + +(define (read-sgi-raw port dim x y z) + (case dim + ((1) (let1 v (make-u8vector x) + (read-block! v port) + (list x 1 1 v))) + ((2) (let1 v (make-u8vector (* x y)) + (read-block! v port) + (list x y 1 v))) + ((3) (let ((planes (list-ec (: i z) + (let1 v (make-u8vector (* x y)) + (read-block! v port) + v))) + (vec (make-u8vector (* x y z)))) + (dotimes (i (* x y)) + (for-each-with-index + (lambda (j plane) + (u8vector-set! vec (+ (* i z) j) (u8vector-ref plane i))) + planes)) + (list x y z vec))) + (else #f))) + +(define (read-sgi-rle port dim x y z) + (let ((starts (make-u32vector (* y z))) ; scan line start indexes + (sizes (make-u32vector (* y z))) ; compressed scan line sizes + (compressed #f) + (offset (+ 512 (* 2 4 y z))) ; offset to the compressed data + (vec (make-u8vector (* x y z)))) ; result vector + (read-block! starts port 0 -1 'big-endian) + (read-block! sizes port 0 -1 'big-endian) + (set! compressed + (string->u8vector + (call-with-output-string (cut copy-port port <>)))) + + (dotimes (zz z) + (dotimes (yy y) + (let ((start (- (u32vector-ref starts (+ (* zz y) yy)) offset)) + (size (u32vector-ref sizes (+ (* zz y) yy)))) + (let1 line + (uvector-alias <u8vector> compressed start (+ start size)) + (do ((xx (+ (* x yy z) zz) xx) + (k 0 k)) + ((>= k size)) + (let1 b (u8vector-ref line k) + (inc! k) + (cond + ((= b 0)) + ((< b 128) ;; repeat next byte to b times + (let1 bb (u8vector-ref line k) + (inc! k) + (dotimes (n b) + (u8vector-set! vec xx bb) + (inc! xx z)))) + (else ;; copy (- b 128) bytes + (dotimes (n (- b 128)) + (u8vector-set! vec xx (u8vector-ref line k)) + (inc! k) + (inc! xx z))))) + ))))) + + (list x y z vec))) + + +(provide "gl/simple/image") + =================================================================== --- gauche-gl-0.4.4.orig/lib/gl/math3d.scm (revision 301) +++ gauche-gl-0.4.4/lib/gl/math3d.scm (working copy) @@ -1,7 +1,7 @@ ;;; ;;; gl/math3d.scm - auxiliary vector arithmetics for 3D graphics ;;; -;;; Copyright(C) 2002-2003 by Shiro Kawai (shiro@acm.org) +;;; Copyright (c) 2002-2008 Shiro Kawai <shiro@acm.org> ;;; ;;; Permission to use, copy, modify, distribute this software and ;;; accompanying documentation for any purpose is hereby granted, @@ -274,6 +274,8 @@ (vector4f-add x y)) (define-method object-+ ((x <point4f>) (y <vector4f>)) (point4f-add x y)) +(define-method object-+ ((y <vector4f>) (x <point4f>)) + (point4f-add x y)) (define-method object-+ ((x <quatf>) (y <quatf>)) (quatf-add x y)) @@ -289,6 +291,13 @@ (define-method object-- ((x <vector4f>)) (vector4f-sub #,(vector4f 0 0 0) x)) +(define-method object-* ((v <vector4f>) (f <real>)) + (vector4f-mul v f)) +(define-method object-* ((f <real>) (v <vector4f>)) + (vector4f-mul v f)) +(define-method object-/ ((v <vector4f>) (f <real>)) + (vector4f-div v f)) + (define-method object-* ((m <matrix4f>) (v <vector4f>)) (matrix4f-mul m v)) (define-method object-* ((m <matrix4f>) (v <point4f>)) =================================================================== --- gauche-gl-0.4.4.orig/lib/gl/simple-image.scm (revision 301) +++ gauche-gl-0.4.4/lib/gl/simple-image.scm (working copy) @@ -1,128 +1,9 @@ ;;; ;;; simple-image.scm - simple image I/O ;;; -;;; Copyright (c) 2005 Shiro Kawai, All rights reserved. +;;; This is obsoleted. Use gl.simple.image instead. ;;; -;;; Redistribution and use in source and binary forms, with or without -;;; modification, are permitted provided that the following conditions -;;; are met: -;;; -;;; 1. Redistributions of source code must retain the above copyright -;;; notice, this list of conditions and the following disclaimer. -;;; -;;; 2. 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. -;;; -;;; 3. Neither the name of the authors 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: simple-image.scm,v 1.1 2005/06/08 12:10:43 shirok Exp $ -;;; -;; For serious image handling, I'd recommend you to use a serious -;; library (Gauche's GD binding sounds nice, though there's no working -;; version yet). This module provides a minimal routines to do -;; some experiment and testing with Gauche-gl alone. - (define-module gl.simple-image - (export read-sgi-image read-sgi-image-from-port) - (use gauche.uvector) - (use gauche.sequence) - (use util.match) - (use binary.pack) - (use srfi-42) - ) -(select-module gl.simple-image) - -(define (read-sgi-image file) - (call-with-input-file file read-sgi-image-from-port)) - -;; read-sgi-image-from-port :: port -> (width, height, nchannels, data) -(define (read-sgi-image-from-port port) - (match-let1 (magic compr bpp dim x y z min max pad1 name cmap . pad2) - (unpack "nccnnnnNNNA80Nc404" :input port) - (and (= magic 474) - (= bpp 1) ;; we only support 8bit/channel for now. - (= cmap 0) ;; we only support direct pixel values for now. - (if (= compr 1) - (read-sgi-rle port dim x y z) - (read-sgi-raw port dim x y z))))) - -(define (read-sgi-raw port dim x y z) - (case dim - ((1) (let1 v (make-u8vector x) - (read-block! v port) - (list x 1 1 v))) - ((2) (let1 v (make-u8vector (* x y)) - (read-block! v port) - (list x y 1 v))) - ((3) (let ((planes (list-ec (: i z) - (let1 v (make-u8vector (* x y)) - (read-block! v port) - v))) - (vec (make-u8vector (* x y z)))) - (dotimes (i (* x y)) - (for-each-with-index - (lambda (j plane) - (u8vector-set! vec (+ (* i z) j) (u8vector-ref plane i))) - planes)) - (list x y z vec))) - (else #f))) - -(define (read-sgi-rle port dim x y z) - (let ((starts (make-u32vector (* y z))) ; scan line start indexes - (sizes (make-u32vector (* y z))) ; compressed scan line sizes - (compressed #f) - (offset (+ 512 (* 2 4 y z))) ; offset to the compressed data - (vec (make-u8vector (* x y z)))) ; result vector - (read-block! starts port 0 -1 'big-endian) - (read-block! sizes port 0 -1 'big-endian) - (set! compressed - (string->u8vector - (call-with-output-string (cut copy-port port <>)))) - - (dotimes (zz z) - (dotimes (yy y) - (let ((start (- (u32vector-ref starts (+ (* zz y) yy)) offset)) - (size (u32vector-ref sizes (+ (* zz y) yy)))) - (let1 line - (uvector-alias <u8vector> compressed start (+ start size)) - (do ((xx (+ (* x yy z) zz) xx) - (k 0 k)) - ((>= k size)) - (let1 b (u8vector-ref line k) - (inc! k) - (cond - ((= b 0)) - ((< b 128) ;; repeat next byte to b times - (let1 bb (u8vector-ref line k) - (inc! k) - (dotimes (n b) - (u8vector-set! vec xx bb) - (inc! xx z)))) - (else ;; copy (- b 128) bytes - (dotimes (n (- b 128)) - (u8vector-set! vec xx (u8vector-ref line k)) - (inc! k) - (inc! xx z))))) - ))))) - - (list x y z vec))) - - + (extend gl.simple.image)) ; for backward compatibility (provide "gl/simple-image") - =================================================================== --- gauche-gl-0.4.4.orig/examples/simple/minimum-viewer.scm (revision 0) +++ gauche-gl-0.4.4/examples/simple/minimum-viewer.scm (revision 7080) @@ -0,0 +1,12 @@ +;; A minimum demo to use gl.simple.viewer + +(use gl) +(use gl.glut) +(use gl.simple.viewer) + +(define (main args) + (glut-init args) + (simple-viewer-display (lambda () (glut-wire-sphere 2.0 10 8))) + (simple-viewer-window 'demo) + (simple-viewer-run) + 0) =================================================================== --- gauche-gl-0.4.4.orig/examples/glbook/example8-6.scm (revision 301) +++ gauche-gl-0.4.4/examples/glbook/example8-6.scm (working copy) @@ -2,7 +2,7 @@ (use gl) (use gl.glut) -(use gl.simple-image) +(use gl.simple.image) (use gauche.uvector) (use util.match) =================================================================== --- gauche-gl-0.4.4.orig/examples/glbook/example8-8.scm (revision 301) +++ gauche-gl-0.4.4/examples/glbook/example8-8.scm (working copy) @@ -2,7 +2,7 @@ (use gl) (use gl.glut) -(use gl.simple-image) +(use gl.simple.image) (use gauche.uvector) (use gauche.sequence) (use util.match) =================================================================== --- gauche-gl-0.4.4.orig/examples/glbook/example13-7.scm (revision 301) +++ gauche-gl-0.4.4/examples/glbook/example13-7.scm (working copy) @@ -46,7 +46,7 @@ (print-3d-color-vertex buffer count) (inc! count 8)) ((= token GL_LINE_TOKEN) (print "GL_LINE_TOKEN") - (aprint-3d-color-vertex buffer count) (inc! count 8) + (print-3d-color-vertex buffer count) (inc! count 8) (print-3d-color-vertex buffer count) (inc! count 8)) ((= token GL_LINE_RESET_TOKEN) (print "GL_LINE_RESET_TOKEN")