[cello-cvs] CVS cl-opengl
ktilton
ktilton at common-lisp.net
Sat May 13 21:33:49 UTC 2006
Update of /project/cello/cvsroot/cl-opengl
In directory clnet:/tmp/cvs-serv23051
Modified Files:
cl-opengl-config.lisp cl-opengl.asd cl-opengl.lisp
cl-opengl.lpr gl-def.lisp gl-functions.lisp glu-functions.lisp
glut-extras.lisp glut-functions.lisp nehe-14.lisp
ogl-macros.lisp ogl-utils.lisp
Log Message:
Bringing this up to date for Celtk Geras demo and Cello2
--- /project/cello/cvsroot/cl-opengl/cl-opengl-config.lisp 2005/06/15 21:09:09 1.2
+++ /project/cello/cvsroot/cl-opengl/cl-opengl-config.lisp 2006/05/13 21:33:48 1.3
@@ -21,24 +21,3 @@
;;; IN THE SOFTWARE.
(in-package :cl-opengl)
-
-(defparameter *gl-dynamic-lib*
- (make-pathname
- #+lispworks :host #-lispworks :device "c"
- :directory '(:absolute "windows" "system32")
- :name "opengl32"
- :type "dll"))
-
-(defparameter *glu-dynamic-lib*
- (make-pathname
- #+lispworks :host #-lispworks :device "c"
- :directory '(:absolute "windows" "system32")
- :name "glu32"
- :type "dll"))
-
-(defparameter *glut-dynamic-lib*
- (make-pathname
- #+lispworks :host #-lispworks :device "c"
- :directory '(:absolute "0dev" "user" "dynlib")
- :name "freeglut"
- :type "dll"))
\ No newline at end of file
--- /project/cello/cvsroot/cl-opengl/cl-opengl.asd 2005/05/25 03:14:30 1.1
+++ /project/cello/cvsroot/cl-opengl/cl-opengl.asd 2006/05/13 21:33:48 1.2
@@ -1,12 +1,13 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;(declaim (optimize (debug 2) (speed 1) (safety 1) (compilation-speed 1)))
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+;(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
(in-package :asdf)
-#+(or allegro lispworks cmu mcl cormanlisp sbcl scl)
+#-(or openmcl sbcl cmu clisp lispworks ecl allegro cormanlisp)
+(error "Sorry, this Lisp is not yet supported. Patches welcome!")
(defsystem cl-opengl
:name "cl-opengl"
@@ -18,17 +19,17 @@
:long-description "Bindings to most of OpenGL, more on demand"
:perform (load-op :after (op cl-opengl)
(pushnew :cl-opengl cl:*features*))
- :depends-on (:utils-kt :ffi-extender)
+ :depends-on (:hello-cffi)
:serial t
:components ((:file "cl-opengl")
(:file "gl-def" :depends-on ("cl-opengl"))
(:file "gl-constants" :depends-on ("gl-def"))
(:file "gl-functions" :depends-on ("gl-def"))
(:file "glu-functions" :depends-on ("gl-def"))
- (:file "glut-functions" :depends-on ("gl-def"))
- (:file "glut-def" :depends-on ("gl-def"))
- (:file "glut-extras" :depends-on ("gl-def"))
+ (:file "glut-loader" :depends-on ("cl-opengl"))
+ (:file "glut-functions" :depends-on ("glut-loader"))
+ (:file "glut-def" :depends-on ("glut-loader"))
+ (:file "glut-extras" :depends-on ("glut-loader"))
(:file "ogl-macros" :depends-on ("gl-def"))
- (:file "ogl-utils" :depends-on ("gl-def"))
- (:file "nehe-14" :depends-on ("gl-def"))
- ))
+ (:file "ogl-utils" :depends-on ("ogl-macros"))
+ (:file "nehe-14" :depends-on ("ogl-macros"))))
--- /project/cello/cvsroot/cl-opengl/cl-opengl.lisp 2005/07/08 16:26:47 1.2
+++ /project/cello/cvsroot/cl-opengl/cl-opengl.lisp 2006/05/13 21:33:48 1.3
@@ -1,5 +1,4 @@
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-opengl; -*-
-;;________________________________________________________
;;
;;;
;;; Copyright © 2004 by Kenneth William Tilton.
@@ -26,31 +25,17 @@
(defpackage #:cl-opengl
(:nicknames #:ogl)
- (:use #:common-lisp #:ffx)
+ (:use #:common-lisp #:cffi #:ffx)
(:export #:*ogl-listing-p*
- #:glut-get-window
- #:glut-set-window
- #:glut-post-redisplay
#:with-matrix #:with-matrix-mode
#:with-attrib #:with-client-attrib
#:with-gl-begun
#:gl-pushm
#:gl-popm
- #:glut-callback-set
#:cl-opengl-init
#:closed-stream-p
#:*selecting*
#:cl-opengl-reset
- #:cl-opengl-set-home-dir
- #:cl-opengl-get-home-dir
- #:cl-glut-set-home-dir
- #:cl-glut-get-home-dir
- #:cl-opengl-set-gl-dll-filename
- #:cl-opengl-get-gl-dll-filename
- #:cl-opengl-set-glu-dll-filename
- #:cl-opengl-get-glu-dll-filename
- #:cl-glut-set-dll-filename
- #:cl-glut-get-dll-filename
#:ogl-texture
#:ncalc-normalf #:ncalc-normalfv #:ogl-get-int #:ogl-get-boolean
#:v3f #:make-v3f #:v3f-x #:v3f-y #:v3f-z
@@ -61,24 +46,73 @@
#:ogl-pen-move #:with-bitmap-shifted
#:texture-name
#:eltgli #:ogl-tex-activate #:gl-name
- #:mgwclose #:freeg #:glut-bitmap-string #:glut-stroke-string))
+ #:mgwclose #:freeg))
(in-package :cl-opengl)
-(defparameter *opengl-dll* nil)
+(defparameter *selecting* nil)
+
+(push (make-pathname
+ :directory '(:absolute "0devtools" "cffi"))
+ asdf:*central-registry*)
+
+(push (make-pathname
+ :directory '(:absolute "0devtools" "verrazano-support"))
+ asdf:*central-registry*)
+
+(defparameter *gl-dynamic-lib*
+ #+(or win32 windows mswindows)
+ (make-pathname
+ ;; #+lispworks :host #-lispworks :device "C"
+ :directory '(:absolute "windows" "system32")
+ :name "opengl32"
+ :type "dll")
+ #+(or darwin unix powerpc)
+ (make-pathname
+ :directory '(:absolute "System" "Library" "Frameworks"
+ "OpenGL.framework" "Versions" "Current")
+ :name "OpenGL"
+ :type nil))
+
+(defparameter *glu-dynamic-lib*
+ #+(or win32 windows mswindows)
+ (make-pathname
+ ;;; #+lispworks :host #-lispworks :device "C"
+ :directory '(:absolute "windows" "system32")
+ :name "glu32"
+ :type "dll")
+ #+(or darwin unix powerpc)
+ (make-pathname
+ :directory '(:absolute "System" "Library" "Frameworks"
+ "GLU.framework" "Versions" "Current")
+ :name "GLU"
+ :type nil))
+
+(defvar *opengl-dll* nil)
+
+(defun cl-opengl-load ()
+ (declare (ignorable load-oglfont-p))
+ (unless *opengl-dll*
+ (print "loading open GL/GLU")
+ (ffx:load-foreign-library (namestring *gl-dynamic-lib*)) ; :module "open-gl")
+ ;; -lispworks#-lispworks
+ (setf *opengl-dll*
+ (ffx:load-foreign-library
+ (namestring *glu-dynamic-lib*)))))
+
+(eval-when (load eval)
+ (cl-opengl-load))
(defun gl-boolean-test (value)
#+allegro (not (eql value #\null))
#-allegro (not (zerop value)))
+#+yeahyeah
(defun dump-lists (min max)
(loop with start
and end
for lx from min to max
- when (let ((is (gl-is-list lx)))
- (when (gl-boolean-test is)
- (print (list "dl test" lx is (char-code is))))
- (gl-boolean-test is))
+ when (gl-boolean-test (glislist lx))
do (if start
(if end
(if (eql lx (1+ end))
@@ -87,4 +121,31 @@
(if (eql lx (1+ start))
(setf end lx)
(print `(gl ,start))))
- (setf start lx))))
\ No newline at end of file
+ (setf start lx))))
+
+
+(dfenum storagetype
+ char-pixel
+ short-pixel
+ integer-pixel
+ long-pixel
+ float-pixel
+ double-pixel)
+
+(dfenum filtertypes
+ undefined-filter
+ point-filter
+ box-filter
+ triangle-filter
+ hermite-filter
+ hanning-filter
+ hamming-filter
+ blackman-filter
+ gaussian-filter
+ quadratic-filter
+ cubic-filter
+ catrom-filter
+ mitchell-filter
+ lanczos-filter
+ bessel-filter
+ sinc-filter)
\ No newline at end of file
--- /project/cello/cvsroot/cl-opengl/cl-opengl.lpr 2005/06/15 21:09:09 1.2
+++ /project/cello/cvsroot/cl-opengl/cl-opengl.lpr 2006/05/13 21:33:48 1.3
@@ -1,24 +1,21 @@
-;; -*- lisp-version: "7.0 [Windows] (Jun 10, 2005 13:34)"; cg: "1.54.2.17"; -*-
+;; -*- lisp-version: "8.0 [Windows] (May 5, 2006 15:39)"; cg: "1.81"; -*-
(in-package :cg-user)
(defpackage :CL-OPENGL)
(define-project :name :cl-opengl
- :modules (list (make-instance 'module :name "cl-opengl-config.lisp")
- (make-instance 'module :name "cl-opengl.lisp")
+ :modules (list (make-instance 'module :name "cl-opengl.lisp")
(make-instance 'module :name "gl-def.lisp")
(make-instance 'module :name "gl-constants.lisp")
(make-instance 'module :name "gl-functions.lisp")
(make-instance 'module :name "glu-functions.lisp")
- (make-instance 'module :name "glut-functions.lisp")
- (make-instance 'module :name "glut-def.lisp")
- (make-instance 'module :name "glut-extras.lisp")
(make-instance 'module :name "ogl-macros.lisp")
- (make-instance 'module :name "ogl-utils.lisp")
- (make-instance 'module :name "nehe-14.lisp"))
+ (make-instance 'module :name "ogl-utils.lisp"))
:projects (list (make-instance 'project-module :name
- "c:\\0dev\\hello-c\\hello-c"))
+ "..\\cells\\utils-kt\\utils-kt")
+ (make-instance 'project-module :name
+ "..\\hello-cffi\\hello-cffi"))
:libraries nil
:distributed-files nil
:internally-loaded-files nil
--- /project/cello/cvsroot/cl-opengl/gl-def.lisp 2005/05/25 03:14:30 1.1
+++ /project/cello/cvsroot/cl-opengl/gl-def.lisp 2006/05/13 21:33:48 1.2
@@ -30,7 +30,7 @@
(defun aforef (o n)
- (uffi:deref-array o '(:array :int) n))
+ (mem-aref o :int n))
(dft glenum #-allegro-v5.0.1 :unsigned-int #+allegro-v5.0.1 :int integer)
@@ -42,18 +42,21 @@
(dft gluint #-allegro-v5.0.1 :unsigned-int #+allegro-v5.0.1 :int integer)
(dft glushort #-allegro-v5.0.1 :unsigned-int #+allegro-v5.0.1 :int integer)
-(dft glfloat #+lispworks :lisp-single-float #-lispworks :float single-float)
-(dft glclampf #+lispworks :lisp-single-float #-lispworks :float single-float)
+(dft glfloat :float single-float)
+(dft glclampf :float single-float)
+
+;;;(dft glfloat #+lispworks :lisp-single-float #-lispworks :float single-float)
+;;;(dft glclampf #+lispworks :lisp-single-float #-lispworks :float single-float)
(dft gldouble :double double-float)
(dft glclampd :double double-float)
-(dft glboolean :unsigned-byte #+allegro character #-allegro number)
-(dft glbyte :byte #+allegro character #-allegro number) ;; typedef signed char GLbyte;
+(dft glboolean :unsigned-char #+allegro character #-allegro number)
+(dft glbyte :char #+allegro character #-allegro number) ;; typedef signed char GLbyte;
(dft glvoid :void integer)
(dft glshort #-allegro-v5.0.1 :short #+allegro-v5.0.1 :int integer)
-(dft glubyte :unsigned-byte #+allegro character #-allegro number)
+(dft glubyte :unsigned-char #+allegro character #-allegro number)
--- /project/cello/cvsroot/cl-opengl/gl-functions.lisp 2005/07/08 16:26:47 1.2
+++ /project/cello/cvsroot/cl-opengl/gl-functions.lisp 2006/05/13 21:33:48 1.3
@@ -23,10 +23,11 @@
(in-package #:cl-opengl)
(defparameter *ogl-listing-p* nil)
-(defun-ogl :void "open-gl" "glFlush" ())
+
(defun-ogl :void "open-gl" "glMaterialfv" (glenum face glenum pname glfloat *params))
+(defun-ogl :void "open-gl" "glFlush" ())
#| drawing functions |#
@@ -77,6 +78,7 @@
(defun-ogl :void "open-gl" "glIndexiv" (glint *c ))
(defun-ogl :void "open-gl" "glIndexsv" (glshort *c ))
(defun-ogl :void "open-gl" "glIndexubv" (glubyte *c ))
+
(defun-ogl :void "open-gl" "glColor3b" (glbyte red glbyte green glbyte blue ))
(defun-ogl :void "open-gl" "glColor3d" (gldouble red gldouble green gldouble blue ))
(defun-ogl :void "open-gl" "glColor3f" (glfloat red glfloat green glfloat blue ))
@@ -354,14 +356,14 @@
glfloat xmove glfloat ymove
char *data))
-#+not
+#+(or)
(DEFUN-FFX :VOID "open-gl" "glBitmap"
(GLSIZEI WIDTH GLSIZEI HEIGHT
GLFLOAT XORIG GLFLOAT YORIG
GLFLOAT XMOVE GLFLOAT YMOVE
GLbyte *DATA))
-#+not
+#+(or)
(DEF-FUNCTION ("glBitmap" GLBITMAP)
((WIDTH GLSIZEI) (HEIGHT GLSIZEI) (XORIG GLFLOAT) (YORIG GLFLOAT) (XMOVE GLFLOAT)
(YMOVE GLFLOAT) (*DATA :pointer-void))
@@ -405,4 +407,4 @@
(defun-ogl :void "open-gl" "glEndList" ())
(defun-ogl :void "open-gl" "glCallList" (gluint list ))
(defun-ogl :void "open-gl" "glCallLists" (glsizei n glenum type glvoid *lists))
-(defun-ogl :void "open-gl" "glListBase" (gluint base))
\ No newline at end of file
+(defun-ogl :void "open-gl" "glListBase" (gluint base))
--- /project/cello/cvsroot/cl-opengl/glu-functions.lisp 2005/07/08 16:26:47 1.3
+++ /project/cello/cvsroot/cl-opengl/glu-functions.lisp 2006/05/13 21:33:48 1.4
@@ -225,7 +225,19 @@
(defun-ogl :void "gl-util" "gluTessBeginPolygon" (:void *tess GLvoid *data))
(defun-ogl :void "gl-util" "gluTessEndContour" (:void *tess))
(defun-ogl :void "gl-util" "gluTessEndPolygon" (:void *tess))
-(defun-ogl :void "gl-util" "gluTessNormal" (:void *tess GLdouble valueX GLdouble valueY GLdouble valueZ))
+(defun-ogl :void "gl-util" "gluTessNormal" (:void *tess GLdouble valueX
+ GLdouble valueY GLdouble valueZ))
(defun-ogl :void "gl-util" "gluTessProperty" (:void *tess GLenum which GLdouble data))
(defun-ogl :void "gl-util" "gluTessVertex" (:void *tess GLdouble *location GLvoid *data))
+
+#+save
+(PROGN
+ (ffx:DEF-FUNCTION ("gluTessVertex" GLUTESSVERTEX)
+ ((*TESS (* :VOID)) (*LOCATION (* (:array GLDOUBLE))) (*DATA (* GLVOID))) :RETURNING :VOID :MODULE
+ "gl-util")
+ (DEFUN GLU-TESS-VERTEX (*TESS *LOCATION *DATA)
+ (LET ((tess *TESS) (loc *LOCATION) (dat *DATA))
+ (PROG1 (GLUTESSVERTEX tess loc dat) (PROGN (GLEC '|gluTessVertex|)))))
+ (EVAL-WHEN (COMPILE EVAL LOAD) (EXPORT '(GLUTESSVERTEX GLU-TESS-VERTEX))))
+
(defun-ogl :void "gl-util" "gluTessCallback" (:void *tess GLenum which :void *callback))
--- /project/cello/cvsroot/cl-opengl/glut-extras.lisp 2005/05/25 03:14:31 1.1
+++ /project/cello/cvsroot/cl-opengl/glut-extras.lisp 2006/05/13 21:33:48 1.2
@@ -26,8 +26,7 @@
(eval-when (compile eval load)
(export '(ffi-glut-id glut-callback-set glut-callbacks-set cl-glut-init xfg)))
-(defparameter *glut-dll* nil)
-
+#+dead?
(defun xfg ()
#+allegro
(dolist (lib '("freeglut" "glu32" "opengl32"))
@@ -40,16 +39,8 @@
(defparameter *mg-glut-display-busy* nil)
(defun cl-glut-init ()
- (cl-opengl-init)
- (unless *glut-dll*
- (print (list "loading GLUT" *glut-dynamic-lib* (probe-file *glut-dynamic-lib*)))
- (assert (setq *glut-dll* (uffi:load-foreign-library *glut-dynamic-lib*
- :force-load #+lispworks nil #-lispworks t
- :module "glut"))
- () "Unable to load GLUT from: ~a" *glut-dynamic-lib* ))
-
- (let ((glut-state (glutget (coerce glut_init_state 'integer))))
- (format t "~&glut state 2 ~a" glut-state)
+ (let ((glut-state (glutget (coerce +glut-init-state+ 'integer))))
+ (format t "~&cl-glut-init > glut state ~a" glut-state)
(if (zerop glut-state)
(progn
(print "about to initialize")
@@ -57,7 +48,7 @@
(setf (eltf argc 0) 0)
(unwind-protect
(progn
- (glut-init argc (uffi:make-null-pointer '(:array :cstring)))
+ (glutInit argc (make-null-pointer '(:array :cstring)))
(print "glut initialised")
)
(fgn-free argc))))
@@ -73,50 +64,39 @@
(or (not (zerop (glgeterror)))
(zerop w))))
-(let ((mm (uffi:allocate-foreign-object :int 1)))
+(let ((mm (ffx:allocate-foreign-object :int 1)))
(defun get-matrix-mode ()
- (glgetintegerv gl_matrix_mode mm)
- (uffi:deref-array mm '(:array :int) 0)))
+ (glgetintegerv +gl-matrix-mode+ mm)
+ (ffx:deref-array mm '(:array :int) 0)))
-(let ((mm (uffi:allocate-foreign-object :int 1))
- (sd (uffi:allocate-foreign-object :int 1)))
+(let ((mm (ffx:allocate-foreign-object :int 1))
+ (sd (ffx:allocate-foreign-object :int 1)))
(defun get-stack-depth ()
- (glgetintegerv gl_matrix_mode mm)
- (let ((mmi (uffi:deref-array mm '(:array :int) 0)))
+ (glgetintegerv +gl-matrix-mode+ mm)
+ (let ((mmi (ffx:deref-array mm '(:array :int) 0)))
(glgetintegerv
(cond
- ((eql mmi gl_modelview) gl_modelview_stack_depth)
- ((eql mmi gl_projection) gl_projection_stack_depth)
- ((eql mmi gl_texture) gl_texture_stack_depth)
+ ((eql mmi +gl-modelview+) +gl-modelview-stack-depth+)
+ ((eql mmi +gl-projection+) +gl-projection-stack-depth+)
+ ((eql mmi +gl-texture+) +gl-texture-stack-depth+)
(t (break "bad matrix")))
sd)
- (uffi:deref-array sd '(:array :int) 0))))
+ (ffx:deref-array sd '(:array :int) 0))))
(defun cello-matrix-mode (&optional (tag :anon))
- (let ((mm (uffi:allocate-foreign-object :int 1))
+ (let ((mm (ffx:allocate-foreign-object :int 1))
)
- (glgetintegerv gl_matrix_mode mm)
- (let ((mmi (uffi:deref-array mm '(:array :int) 0)))
+ (glgetintegerv +gl-matrix-mode+ mm)
+ (let ((mmi (ffx:deref-array mm '(:array :int) 0)))
(unwind-protect
(cond
- ((eql mmi gl_modelview) :model-view)
- ((eql mmi gl_projection) :projection)
- ((eql mmi gl_texture) :texture)
+ ((eql mmi +gl-modelview+) :model-view)
+ ((eql mmi +gl-projection+) :projection)
+ ((eql mmi +gl-texture+) :texture)
(t (break "gl-stack-depth> unexpected matrix mode ~a ~a" tag mmi)))
- (uffi:free-foreign-object mm)))))
+ (ffx:free-foreign-object mm)))))
-(defun glut-stroke-string (font string)
- "Font must already have been converted to a pointer, string must be Lisp string"
- (dotimes (n (length string))
- ;;(print `(stroke ,n ,(elt string n)))
- (glut-stroke-character font (coerce (char-code (elt string n)) 'integer))
- ))
-
-(defun glut-bitmap-string (font string)
- "Font must already have been converted to a pointer, string must be Lisp string"
- (loop for c across string
- do (glut-bitmap-character font (char-code c))))
(defun glut-callback-set (setter settee)
(when settee
--- /project/cello/cvsroot/cl-opengl/glut-functions.lisp 2005/05/25 03:14:31 1.1
+++ /project/cello/cvsroot/cl-opengl/glut-functions.lisp 2006/05/13 21:33:48 1.2
@@ -55,25 +55,22 @@
(dfc glut_action_on_window_close #x01f9)
(defun-ffx :void "glut" "glutSetOption" (glenum e-what :int value))
-(defun-ffx :void "glut" "glutWCurrencyAssert" ())
-(defun-ffx :void "glut" "glutWCurrencySet" ())
-(defun-ffx :void "glut" "glutWFill" (:float r :float g :float b :float alpha))
-(defun-ffx :void "glut" "glutWFill2" (:float r :float g :float b :float alpha))
-(defun-ffx :void "glut" "glutWClearColor" (:float r :float g :float b :float alpha))
-(defun-ffx :void "glut" "glutWClear" ())
+;;;(defun-ffx :void "glut" "glutWFill" (:float r :float g :float b :float alpha))
+;;;(defun-ffx :void "glut" "glutWFill2" (:float r :float g :float b :float alpha))
+;;;(defun-ffx :void "glut" "glutWClearColor" (:float r :float g :float b :float alpha))
+;;;(defun-ffx :void "glut" "glutWClear" ())
(defun-ffx :int "glut" "glutCreateWindow" (:cstring title))
(defun-ffx :int "glut" "glutCreateSubWindow" (:int win :int x :int y :int width :int height))
(defun-ffx :void "glut" "glutDestroyWindow" (:int win))
-(defun-ffx :void "glut" "fgDeinitialize" ())
+;;;(defun-ffx :void "glut" "fgDeinitialize" ())
-(ff-defun-callable :cdecl :void mgwclose ()
+
+(ff-defun-callable :cdecl :void mgwclose ()
(print "closing callback entered"))
-(defpackage #:cl-opengl
- (:nicknames #:ogl)
- (:use)
- (:export #:mgwclose #:freeg #:glut-bitmap-string #:glut-stroke-string))
+(eval-when (compile load eval)
+ (export '(mgwclose freeg glut-bitmap-string glut-stroke-string)))
(defun freeg () t)
@@ -81,7 +78,7 @@
(defun-ffx :void "glut" "glutPostWindowRedisplay" (:int win))
(defun-ffx :void "glut" "glutSwapBuffers" ())
(defun-ffx :int "glut" "glutGetWindow" ())
-(defun-ffx :int "glut" "glutDestroyPending" ())
+;;;(defun-ffx :int "glut" "glutDestroyPending" ())
(defun-ffx :void "glut" "glutSetWindow" (:int win))
(defun-ffx :void "glut" "glutSetWindowTitle" (:cstring title))
(defun-ffx :void "glut" "glutSetIconTitle" (:cstring title))
@@ -96,9 +93,12 @@
(defun-ffx :void "glut" "glutSetCursor" (:int cursor))
(defun-ffx :void "glut" "glutWarpPointer" (:int x :int y))
-;;;(defun-ffx :void "glut" "glutInit" (integer argc integer argv)) no dice
+
#-cormanlisp
+(defun-ffx :void "glut" "glutInit" (:int *argc :void *argv))
+
+#+original-cormanlisp
(ff-def-call ("glut" glut-init "glutInit")
((argc (* :int))
(argv (* :void))))
@@ -115,7 +115,7 @@
(defun-ffx :void "glut" "glutInitDisplayString" (:cstring string))
(defun-ffx :void "glut" "glutLeaveMainLoop" ())
(defun-ffx :void "glut" "glutMainLoop" ())
-(defun-ffx :void "glut" "glutCheckLoop" ())
+;;;(defun-ffx :void "glut" "glutCheckLoop" ())
(defun-ffx :void "glut" "glutMainLoopEvent" ())
@@ -171,13 +171,16 @@
(defun-ffx :int "glut" "glutBitmapWidth" (:void *font :int character))
(defun-ffx :int "glut" "glutBitmapHeight" (:void *font))
-(defun-ffx glfloat "glut" "glutBitmapXOrig" (:void *font))
-(defun-ffx glfloat "glut" "glutBitmapYOrig" (:void *font))
+;;;(defun-ffx glfloat "glut" "glutBitmapXOrig" (:void *font))
+;;;(defun-ffx glfloat "glut" "glutBitmapYOrig" (:void *font))
(defun-ffx :void "glut" "glutStrokeCharacter" (:void *font :int character))
-(defun-ffx glfloat "glut" "glutStrokeDescent" (:void *font))
+;;;(DEF-FUNCTION ("glutStrokeCharacter" GLUTSTROKECHARACTER)
+;;; ((*FONT (* :VOID)) (CHARACTER :INT)) :RETURNING :VOID :MODULE "glut")
+;;;(CFFI:DEFCFUN ("glutStrokeCharacter" GLUTSTROKECHARACTER) :VOID (*FONT :POINTER) (CHARACTER :INT))
+;;;(defun-ffx glfloat "glut" "glutStrokeDescent" (:void *font))
-#+test
+#+(or)
(list
(glut-bitmap-height glut_bitmap_times_roman_24)
(glut-bitmap-width glut_bitmap_times_roman_24 (char-code #\h)))
@@ -185,7 +188,7 @@
(defun-ffx :int "glut" "glutStrokeWidth" (:void *font :int character))
(defun-ffx glfloat "glut" "glutStrokeHeight" (:void *font))
-#+test
+#+(or)
(list
(glut-stroke-height glut_stroke_mono_roman)
(glut-stroke-width glut_stroke_roman (char-code #\h)))
--- /project/cello/cvsroot/cl-opengl/nehe-14.lisp 2005/07/08 16:26:47 1.2
+++ /project/cello/cvsroot/cl-opengl/nehe-14.lisp 2006/05/13 21:33:48 1.3
@@ -22,154 +22,61 @@
(in-package :cl-opengl)
+
(defconstant wcx 640) ;; Window Width
(defconstant wcy 480) ;; Window Height
-(defparameter g_rot 0.0f0)
-
-(ff-defun-callable :cdecl :void nh14disp ()
- (nh14-disp))
-
-#+not
-(defun nh14-disp ()
- (gl-load-identity) ;; Reset The Current Modelview Matrix
- (gl-clear-color 0.0 0.0 0.0 0.5)
- (gl-clear (+ gl_color_buffer_bit gl_depth_buffer_bit))
-
- (gl-translatef 0.0f0 0.0f0 2.0f0) ;; Move Into The Screen
-
- (font-glut-preview)
-
- (gl-rotatef g_rot 1.0f0 0.0f0 0.0f0) ;; Rotate On The X Axis
- (gl-rotatef (* g_rot 1.5f0) 0.0f0 1.0f0 0.0f0) ;; Rotate On The Y Axis
- (gl-rotatef (* g_rot 1.4f0) 0.0f0 0.0f0 1.0f0) ;; Rotate On The Z Axis
- (gl-scalef 0.002 0.003 0.002)
-
- ;; Pulsing Colors Based On The Rotation
- (gl-color3f (* 1.0f0 (cos (/ g_rot 20.0f0)))
- (* 1.0f0 (sin (/ g_rot 25.0f0)))
- (- 1.0f0 (* 0.5f0 (cos (/ g_rot 17.0f0)))))
-
- (with-matrix ()
- (gl-line-width 3)
- (glut-stroke-string (ffi-glut-id glut_stroke_roman)
- (format nil "NeHe - ~a" (/ g_rot 50.0))))
-
- (gl-line-width 1)
- (glut-wire-teapot 1000)
-
- (incf g_rot 0.4f0)
-
- (glut-swap-buffers)
- (glut-post-redisplay))
-
-(defun nh14-disp ()
- (gl-load-identity) ;; Reset The Current Modelview Matrix
- (gl-clear-color 0.0 0.0 0.0 0.5)
- (gl-clear (+ gl_color_buffer_bit gl_depth_buffer_bit))
-
- (gl-translatef 0.0f0 0.0f0 2.0f0) ;; Move Into The Screen
-
- (gl-rotatef g_rot 1.0f0 0.0f0 0.0f0) ;; Rotate On The X Axis
- (gl-rotatef (* g_rot 1.5f0) 0.0f0 1.0f0 0.0f0) ;; Rotate On The Y Axis
- (gl-rotatef (* g_rot 1.4f0) 0.0f0 0.0f0 1.0f0) ;; Rotate On The Z Axis
-
- ;; Pulsing Colors Based On The Rotation
- (gl-color3f (* 1.0f0 (cos (/ g_rot 20.0f0)))
- (* 1.0f0 (sin (/ g_rot 25.0f0)))
- (- 1.0f0 (* 0.5f0 (cos (/ g_rot 17.0f0)))))
-
- (gl-line-width 1)
- (glut-wire-teapot 1)
-
- (incf g_rot 0.4f0)
+(defparameter g-rot 0.0f0)
- (glut-swap-buffers)
- (glut-post-redisplay))
-
-#+test
-(lesson-14)
-(defun font-glut-preview ()
- (with-matrix ()
- (gl-color3f 1 1 1)
- (gl-scalef 0.007 0.007 0.0)
- (loop for bitmap-font in
- '(glut_bitmap_8_by_13 glut_bitmap_9_by_15
- glut_bitmap_helvetica_10 glut_bitmap_helvetica_12 glut_bitmap_helvetica_18
- glut_bitmap_times_roman_10 glut_bitmap_times_roman_24)
- for id = (symbol-value bitmap-font)
- for y-pos = -50 then (round (- y-pos (glut-bitmap-height (ffi-glut-id id)) 10))
- do
- (assert (numberp id))
- #+shh (if (ogl-get-boolean gl_current_raster_position_valid)
- (print (list :ok bitmap-font (glut-bitmap-height (ffi-glut-id id)) y-pos id))
- (trc "rasterpos offscreen" self :g-offset (g-offset self)))
- (gl-raster-pos3i -250 y-pos 0) ;;(incf zpos 500))
- (glut-bitmap-string (ffi-glut-id id) (format nil "Hello, ~a" bitmap-font))))
-
- (with-matrix ()
- (gl-translatef -2 1 0)
- (gl-scalef 0.001 0.001 0.0)
- (gl-line-width 3)
- (loop for stroke-font in
- '(glut_stroke_mono_roman glut_stroke_roman)
- for id = (symbol-value stroke-font)
- for y-pos = 0 then (round (- y-pos (* 1.1 (/ (glut-stroke-height (ffi-glut-id id)) 1))))
- do
- (assert (numberp id))
- ;(print (list stroke-font (glut-stroke-height (ffi-glut-id id)) y-pos id))
- (gl-translatef 0 y-pos 0)
-
- (let ((msg (format nil "Hello, ~a ~a" (round (glut-stroke-height (ffi-glut-id id)))
- stroke-font)))
- (uffi:with-cstring (cc msg)
- (glut-stroke-string (ffi-glut-id id) msg)
- (gl-translatef (- (glut-stroke-length (ffi-glut-id id) cc))
- 0 0))))))
+(defparameter *disp-ct* 0)
+(defvar *working-objects*)
-#+test
-(lesson-14)
+(ff-defun-callable :cdecl :void mgwclose ()
+ (print "closing callback entered"))
+#+nextttt
(defun lesson-14 (&optional (dispfunc 'nh14disp))
+ (declare (ignorable dispfunc))
+ (setf *disp-ct* 0
+ *working-objects* (make-hash-table))
- (let ((*gl-begun* nil))
- (cl-glut-init)
- (glut-set-option glut_action_on_window_close glut_action_glutmainloop_returns)
-
- (glut-init-display-mode (+ glut_rgb glut_double)) ;; Display Mode (Rgb And Double Buffered)
- (glut-init-window-size 640 480) ;; Window Size If We Start In Windowed Mode
-
- (let ((key "NeHe's OpenGL Framework"))
- (uffi:with-cstring (key-native key)
- (glut-create-window key-native)))
-
- ;(init) ; // Our Initialization
- ;; Set up the callbacks in OpenGL/GLUT
- (glut-display-func (ff-register-callable dispfunc))
- (glut-wm-close-func (ff-register-callable 'mgwclose))
- (glut-keyboard-func (ff-register-callable 'mgwkey))
-
- (gl-matrix-mode gl_projection)
- (gl-load-identity)
- (glu-perspective 70 1 1 1000)
- (glu-look-at 0d0 0d0 5d0 0d0 0d0 0d0 0d0 1d0 0d0)
-
- (gl-matrix-mode gl_modelview)
- (gl-load-identity)
-
-
- (gl-clear-depth 1d0)
-
- (glutmainloop)
- #+not (do ()
- ((zerop (glut-get-window)))
- ;;(format t "before main loop ~a | ~&" (glut-get-window))
- (glutmainloopevent)
- (sleep 0.08)
- )))
+ (progn ;; with-open-file (*standard-output* "/0dev/nh14.log" :direction :output :if-exists :new-version)
+ (let ((*gl-begun* nil))
+ (cl-glut-init)
+ (glutsetoption +glut-action-on-window-close+ +glut-action-glutmainloop-returns+)
+
+ (glutinitdisplaymode (+ +glut-rgb+ +glut-double+)) ;; Display Mode (Rgb And Double Buffered)
+ (glutinitwindowsize 640 480) ;; Window Size If We Start In Windowed Mode
+
+ (let ((key "NeHe's OpenGL Framework"))
+ (uffi:with-cstring (key-native key)
+ (glutcreatewindow key-native)))
+
+ ;(init) ; // Our Initialization
+ ;; Set up the callbacks in OpenGL/GLUT
+ (glutdisplayfunc (ff-register-callable dispfunc))
+ (glutwmclosefunc (ff-register-callable 'mgwclose))
+ (glutkeyboardfunc (ff-register-callable 'mgwkey))
+ (glmatrixmode gl_projection)
+ (glloadidentity)
+ (gluperspective 70d0 1d0 1d0 1000d0)
+ (glulookat 0d0 0d0 5d0 0d0 0d0 0d0 0d0 1d0 0d0)
+
+ (glmatrixmode gl_modelview)
+ (glloadidentity)
+
+
+ (glcleardepth 1d0)
+ (glutmainloop)
+ #+(or) (do ()
+ ((zerop (glutgetwindow)))
+ ;;(format t "before main loop ~a | ~&" (glutgetwindow))
+ (glutmainloopevent)
+ (sleep 0.08)
+ ))))
-#+test
+#+(or)
(lesson-14)
(ff-defun-callable :cdecl :void mgwkey ((k :int) (x :int) (y :int))
@@ -179,11 +86,53 @@
(defun mgwkeyi (k x y)
(declare (ignorable k x y))
(print (list "mgwkey" k x y (glutgetwindow)))
- (let ((mods (glut-get-modifiers)))
+ (let ((mods (glutgetmodifiers)))
(declare (ignorable mods))
- (print (list :keyboard k mods x y (code-char (logand k #xff))#+not(glut-get-window)))
+ (print (list :keyboard k mods x y (code-char (logand k #xff))#+(or)(glut-get-window)))
(case (code-char (logand k #xff))
(#\escape (progn
(print (list "destroying window" (glutgetwindow) )
)
- (glut-destroy-window (glutgetwindow)))))))
\ No newline at end of file
+ (glutDestroyWindow (glutgetwindow)))))))
+
+(ff-defun-callable :cdecl :void nh14disp ()
+ (nh14-disp))
+
+#+nexttttt
+(defun nh14-disp ()
+ (glloadidentity) ;; Reset The Current Modelview Matrix
+
+ (glclearcolor 0.0 0.0 0.0 0.5)
+ (glclear (+ gl_color_buffer_bit gl_depth_buffer_bit))
+
+ (glTranslatef 0.0f0 0.0f0 2.0f0) ;; Move Into The Screen
+
+ ;;(font-glut-preview)
+
+ (glRotatef g-rot 1.0f0 0.0f0 0.0f0) ;; Rotate On The X Axis
+ (glRotatef (* g-rot 1.5f0) 0.0f0 1.0f0 0.0f0) ;; Rotate On The Y Axis
+ (glRotatef (* g-rot 1.4f0) 0.0f0 0.0f0 1.0f0) ;; Rotate On The Z Axis
+ (glScalef 0.002 0.003 0.002)
+
+ ;; Pulsing Colors Based On The Rotation
+ (glcolor3f (* 1.0f0 (cos (/ g-rot 20.0f0)))
+ (* 1.0f0 (sin (/ g-rot 25.0f0)))
+ (- 1.0f0 (* 0.5f0 (cos (/ g-rot 17.0f0)))))
+
+ (with-matrix ()
+ (gllinewidth 3f0)
+ (let ((x (format nil "NeHe - ~a" (/ g-rot 50.0))))
+ (with-cstring (msg x)
+ (glutstrokestring glut_stroke_roman msg))))
+
+
+ (progn
+ (gllinewidth 1f0)
+ (glutwireteapot 1000d0))
+
+ (incf g-rot 0.10)
+
+ (glutswapbuffers)
+ (glutPostRedisplay)
+ )
+
--- /project/cello/cvsroot/cl-opengl/ogl-macros.lisp 2005/07/08 16:26:47 1.2
+++ /project/cello/cvsroot/cl-opengl/ogl-macros.lisp 2006/05/13 21:33:48 1.3
@@ -1,5 +1,4 @@
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-opengl; -*-
-;;________________________________________________________
;;
;;;
;;; Copyright © 2004 by Kenneth William Tilton.
@@ -33,16 +32,16 @@
(defun call-with-matrix (load-identity-p matrix-fn matrix-code)
(declare (ignorable matrix-code))
- (gl-push-matrix)
+ (glPushMatrix)
(unwind-protect
(progn
(when load-identity-p
- (gl-load-identity))
+ (glLoadIdentity))
(funcall matrix-fn))
- (gl-pop-matrix)))
+ (glpopmatrix)))
-(defparameter *matrix-mode* GL_MODELVIEW)
+(defparameter *matrix-mode* gl_modelview)
(defmacro with-matrix-mode (mode &body body)
`(unwind-protect
(let ((*matrix-mode* ,mode))
@@ -56,24 +55,24 @@
(let ((mm-pushed (ogl::get-matrix-mode))
(sd-pushed (ogl::get-stack-depth)))
- (gl-push-matrix)
+ (glPushMatrix)
(glec :with-matrix-push)
(unwind-protect
(progn
(when (eql gl_modelview_matrix mm-pushed)
- (gl-get-integerv gl_modelview_stack_depth *stack-depth*)
+ (glgetintegerv 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))
+ (glLoadIdentity))
(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)
+ (glpopmatrix)
(assert (eql sd-pushed (ogl::get-stack-depth))()
"matrix depth deviated ~d during ~a"
(- sd-pushed (ogl::get-stack-depth))
@@ -86,13 +85,13 @@
(lambda () , at body)))
(defun call-with-attrib (attrib-mask attrib-fn)
- (gl-push-attrib attrib-mask)
+ (glpushattrib attrib-mask)
(glec :with-attrib-push)
(unwind-protect
(prog1
(funcall attrib-fn)
(glec :with-attrib))
- (gl-pop-attrib)
+ (glpopattrib)
))
(defmacro with-client-attrib ((&rest attribs) &body body)
@@ -101,13 +100,13 @@
(lambda () , at body)))
(defun call-with-client-attrib (attrib-mask attrib-fn)
- (gl-push-client-attrib attrib-mask)
+ (glpushclientattrib attrib-mask)
(glec :with-client-attrib-push)
(unwind-protect
(prog1
(funcall attrib-fn)
(glec :with-client-attrib))
- (gl-pop-client-attrib)
+ (glpopclientattrib)
))
(defvar *gl-begun*)
@@ -118,29 +117,18 @@
(setf *gl-stop* t)
(break ":nestedbegin"))
(let ((*gl-begun* t))
- (gl-begin ,what)
+ (glbegin ,what)
, at body
- (gl-end)
+ (glend)
(glec :with-gl-begun))))
-(defun cl-opengl-init ()
- (declare (ignorable load-oglfont-p))
- (unless *opengl-dll*
- (print "loading open GL/GLU")
- (uffi:load-foreign-library
- *gl-dynamic-lib*
- :module "open-gl")
- ;; -lispworks#-lispworks
- (setf *opengl-dll* (uffi:load-foreign-library *glu-dynamic-lib*
- :module "gl-util"))))
-
(defun glec (&optional (id :anon))
(unless (and (boundp '*gl-begun*) *gl-begun*)
(let ((e (glgeterror)))
(if (zerop e)
- (unless t ;; (find id '(glutcheckloop glutgetwindow))
+ (unless t
(print `(cool ,id)))
- (if t ;; (null (find id '(glutInitDisplayMode glutInitWindowSize)))
+ (if t
(unless (boundp '*gl-stop*)
(setf *gl-stop* t)
(format t "~&~%OGL error ~a at ID ~a" e id)
--- /project/cello/cvsroot/cl-opengl/ogl-utils.lisp 2005/07/08 16:26:47 1.3
+++ /project/cello/cvsroot/cl-opengl/ogl-utils.lisp 2006/05/13 21:33:48 1.4
@@ -1,5 +1,4 @@
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-opengl; -*-
-;;________________________________________________________
;;
;;;
;;; Copyright © 2004 by Kenneth William Tilton.
@@ -54,7 +53,7 @@
(gl-tex-parameterf gl_texture_2d gl_texture_min_filter gl_linear )
(gl-tex-parameterf gl_texture_2d gl_texture_mag_filter gl_linear )
- (gl-tex-parameteri gl_texture_2d gl_texture_wrap_s tex-wrap) ; gl_repeat for tiling
+ (gl-tex-parameteri gl_texture_2d gl_texture_wrap_s tex-wrap) ; gl-repeat for tiling
(gl-tex-parameteri gl_texture_2d gl_texture_wrap_t tex-wrap) ;--
(loop for plane in planes
@@ -141,22 +140,12 @@
;;(cells::count-it :normalize-3f)
(values (+ (/ x m)) (+ (/ y m)) (+ (/ z m)))))))
-(uffi:def-foreign-type bool* (* glboolean))
-
-#-lispworks
-(declaim (type bool* *ogl-boolean*))
-
(defparameter *ogl-boolean*
(fgn-alloc 'glboolean 1 :ignore))
(defun ogl-get-boolean (gl-code)
(gl-get-booleanv gl-code *ogl-boolean*)
- (not (zerop (uffi:deref-array *ogl-boolean* '(:array glboolean) 0))))
-
-(uffi:def-foreign-type glint* (* glint))
-
-#-lispworks
-(declaim (type glint* *ogl-int*))
+ (not (zerop (mem-aref *ogl-boolean* 'glboolean 0))))
(defparameter *ogl-int*
(fgn-alloc 'glint 1 :ignore))
@@ -165,7 +154,7 @@
(fgn-alloc 'glfloat 1 :ignore))
(defun wrap-float (lisp-float-value)
- (setf (uffi:deref-array *ogl-float-1* '(:array glfloat) 0) (* 1.0f0 lisp-float-value))
+ (setf (mem-aref *ogl-float-1* 'glfloat 0) (* 1.0f0 lisp-float-value))
*ogl-float-1*)
(defun eltgli (v n)
@@ -205,7 +194,7 @@
(defun ogl-pen-move (x y)
;;(ukt::trc "ogl-pen-moving" x y)
- (gl-bitmap 0 0 0 0 x y (uffi:make-null-pointer '(:array :cstring))))
+ (gl-bitmap 0 0 0 0 x y (cffi:null-pointer)))
(defclass ogl-texture ()
((texture-name :accessor texture-name :initform nil)
@@ -219,11 +208,12 @@
(defparameter *dump-matrix* (fgn-alloc 'glfloat 16 :dump-matrix))
+#+(or)
(defun dump-matrix (matrix-id msg)
(gl-get-floatv matrix-id *dump-matrix*)
(format t "~&~a > ~a matrix> ~{~a ~}" msg
(cond ((eql matrix-id gl_modelview_matrix) 'modelview)
- ((eql matrix-id GL_PROJECTION_MATRIX) 'projection))
+ ((eql matrix-id gl_projection_matrix) 'projection))
(loop for n below 16 collecting (eltf *dump-matrix* n))))
More information about the Cello-cvs
mailing list