Update of /project/cello/cvsroot/cello/kt-opengl In directory clnet:/tmp/cvs-serv10432/kt-opengl
Modified Files: gl-constants.lisp gl-def.lisp gl-functions.lisp glu-functions.lisp kt-opengl.lpr ogl-macros.lisp Log Message:
--- /project/cello/cvsroot/cello/kt-opengl/gl-constants.lisp 2006/05/27 06:01:38 1.1 +++ /project/cello/cvsroot/cello/kt-opengl/gl-constants.lisp 2006/07/03 00:35:15 1.2 @@ -174,6 +174,15 @@ (dfc gl_t2f_c4f_n3f_v3f #x2a2c) (dfc gl_t4f_c4f_n3f_v4f #x2a2d)
+(defun matrix-mode-symbol (n) + (ecase n + (#x1700 'gl_modelview) + (#x1701 'gl_projection) + (#x1702 'gl_texture))) + +#+test +(assert (eq 'gl_modelview (matrix-mode-symbol #x1700))) + #| matrix mode |# (dfc gl_modelview #x1700) (dfc gl_projection #x1701) --- /project/cello/cvsroot/cello/kt-opengl/gl-def.lisp 2006/05/27 06:01:38 1.1 +++ /project/cello/cvsroot/cello/kt-opengl/gl-def.lisp 2006/07/03 00:35:16 1.2 @@ -26,6 +26,7 @@ `(defun-ffx ,rtn ,module$ ,name$ (,@type-args) (progn ;;(cells::count-it ,(intern (string-upcase name$) :keyword)) + ;;(format t "~&~(~a~) ~{ ~a~}" ,name$ (list ,@(loop for (nil arg) on type-args by #'cddr collecting arg))) (glec ',(intern name$)))))
(defun aforef (o n) --- /project/cello/cvsroot/cello/kt-opengl/gl-functions.lisp 2006/05/27 06:01:38 1.1 +++ /project/cello/cvsroot/cello/kt-opengl/gl-functions.lisp 2006/07/03 00:35:16 1.2 @@ -22,7 +22,6 @@
(in-package #:kt-opengl)
- (defparameter *ogl-listing-p* nil)
(defun-ogl :void "open-gl" "glFlush" ()) @@ -342,7 +341,9 @@ (defun-ogl :void "open-gl" "glScalef" (glfloat x glfloat y glfloat z )) (defun-ogl :void "open-gl" "glTranslated" (gldouble x gldouble y gldouble z )) (defun-ogl :void "open-gl" "glTranslatef" (glfloat x glfloat y glfloat z )) - +#+diehard (DEFUN-FFX :VOID "open-gl" "glTranslatef" (GLFLOAT X GLFLOAT Y GLFLOAT Z) + (PROGN (GLEC '|glTranslatef|) + (ukt:trc (or (not (zerop x))(not (zerop y))) "TRANSLATED" x y z))) (defun-ogl :void "open-gl" "glBitmap" (glsizei width glsizei height glfloat xorig glfloat yorig glfloat xmove glfloat ymove --- /project/cello/cvsroot/cello/kt-opengl/glu-functions.lisp 2006/05/27 06:01:38 1.1 +++ /project/cello/cvsroot/cello/kt-opengl/glu-functions.lisp 2006/07/03 00:35:16 1.2 @@ -118,7 +118,6 @@ (dfc GLU_TESS_COORD_TOO_LARGE GLU_TESS_ERROR5) (dfc GLU_TESS_NEED_COMBINE_CALLBACK GLU_TESS_ERROR6)
- ;;; **** NURBS constants ****/
;;; NurbsProperty */ @@ -136,7 +135,6 @@ (dfc GLU_PARAMETRIC_ERROR 100216) (dfc GLU_DOMAIN_DISTANCE 100217)
- ;;; NurbsTrim */ (dfc GLU_MAP1_TRIM_2 100210) (dfc GLU_MAP1_TRIM_3 100211) @@ -153,7 +151,6 @@ (dfc GLU_NURBS_ERROR1 100251) (dfc GLU_NURBS_ERROR37 100287)
- (defun-ogl (* glubyte) "gl-util" "gluErrorString" (glenum error)) ;;;(defun-ogl GLubyte *"gl-util" "gluGetString" (GLenum name)) ;;;(defun-ogl void "gl-util" "gluLoadSamplingMatrices" (GLUnurbs *nurb GLfloat *model GLfloat *perspective GLint *view)) --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lpr 2006/06/26 17:05:33 1.2 +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lpr 2006/07/03 00:35:16 1.3 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Jun 21, 2006 9:54)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jun 28, 2006 10:53)"; cg: "1.81"; -*-
(in-package :cg-user)
--- /project/cello/cvsroot/cello/kt-opengl/ogl-macros.lisp 2006/06/26 17:05:33 1.3 +++ /project/cello/cvsroot/cello/kt-opengl/ogl-macros.lisp 2006/07/03 00:35:16 1.4 @@ -24,6 +24,9 @@
(in-package :kt-opengl)
+(eval-when (compile load eval) + (export '(with-gl-translation))) + (defvar *stack-depth* (fgn-alloc :int 1 :ignore))
@@ -41,34 +44,42 @@ (funcall matrix-fn)) (gl-pop-matrix)))
+(defun get-stack-depth (mm) + (gl-get-integerv + (ecase (matrix-mode-symbol mm) + (gl_modelview gl_modelview_stack_depth) + (gl_projection gl_projection_stack_depth) + (gl_texture gl_texture_stack_depth)) + *stack-depth*) + (aforef *stack-depth* 0)) + +(defun get-matrix-mode () + (gl-get-integerv gl_matrix_mode *ogl-int*) + (eltgli *ogl-int* 0)) + #+debugversion (defun call-with-matrix (load-identity-p matrix-fn matrix-code) - (let ((mm-pushed (ogl::get-matrix-mode)) - (sd-pushed (ogl::get-stack-depth))) - - (gl-push-matrix) - (glec :with-matrix-push) - (unwind-protect - (progn - (when (eql gl_modelview_matrix mm-pushed) - (gl-get-integerv gl_modelview_stack_depth *stack-depth*) - (glec :get-stack-depth) - (print `(with-matrix model matrix stack ,(aforef *stack-depth* 0)))) - - (when load-identity-p - (gl-load-identity)) - (prog1 - (funcall matrix-fn) - (glec :with-matrix))) - (assert (eql mm-pushed (ogl::get-matrix-mode))() - "matrix-mode left as ~a instead of ~a by form ~a" - (ogl::get-matrix-mode) mm-pushed matrix-code) - (gl-pop-matrix) - (assert (eql sd-pushed (ogl::get-stack-depth))() - "matrix depth deviated ~d during ~a" - (- sd-pushed (ogl::get-stack-depth)) - matrix-code) - (glec :exit-with-stack)))) + (let* ((mm-pushed (get-matrix-mode)) + (sd-pushed (get-stack-depth mm-pushed))) + (ukt::wtrc (0 100 "with-matrix starts with mode" (matrix-mode-symbol mm-pushed) :depth sd-pushed) + (gl-push-matrix) + (unwind-protect + (progn + (when load-identity-p + (gl-load-identity)) + (prog1 + (funcall matrix-fn) + (glec :with-matrix-body))) + (assert (eql mm-pushed (get-matrix-mode))() + "matrix-mode left as ~a instead of ~a by form ~a" + (ogl::get-matrix-mode) mm-pushed matrix-code) + (ukt:trc "poppping matrix!!!!!" (matrix-mode-symbol (get-matrix-mode)) :from-depth (get-stack-depth (get-matrix-mode))) + (gl-pop-matrix) + (assert (eql sd-pushed (get-stack-depth mm-pushed))() + "matrix depth deviated ~d during ~a" + (- sd-pushed (get-stack-depth mm-pushed)) + matrix-code) + (glec :exit-with-stack)))))
(defmacro with-attrib ((&rest attribs) &body body) `(call-with-attrib @@ -148,16 +159,19 @@ (kt-opengl-init))
(defun glec (&optional (id :anon)) - (unless (and (boundp '*gl-begun*) *gl-begun*) + (if (and (boundp '*gl-begun*) *gl-begun*) + (progn #+shhh (ukt:trc "not checking error inside gl-begin" id)) (let ((e (glgeterror))) (if (zerop e) (unless t ;; (find id '(glutcheckloop glutgetwindow)) (print `(cool ,id))) (if t ;; (null (find id '(glutInitDisplayMode glutInitWindowSize))) - (unless (boundp '*gl-stop*) - (setf *gl-stop* t) - (format t "~&~%OGL error ~a at ID ~a" e id) - ;(break "OGL error ~a at ID ~a" e id) - ) + (if (boundp '*gl-stop*) + (ukt:trc "error but *gl-stop* already bound" e id) + (progn + (setf *gl-stop* t) + (format t "~&~%OGL error ~a at ID ~a" e id) + (break "OGL error ~a at ID ~a" e id) + )) #+sigh (print `("OGL error ~a at ID ~a" ,e ,id)))))))
-
ktilton