From ktilton at common-lisp.net Sat May 13 21:33:49 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 13 May 2006 17:33:49 -0400 (EDT) Subject: [cello-cvs] CVS cl-opengl Message-ID: <20060513213349.1D3CB3000F@common-lisp.net> 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)))) From ktilton at common-lisp.net Mon May 15 16:36:13 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 15 May 2006 12:36:13 -0400 (EDT) Subject: [cello-cvs] CVS hello-c Message-ID: <20060515163613.8A8E67C041@common-lisp.net> Update of /project/cello/cvsroot/hello-c In directory clnet:/tmp/cvs-serv16563 Modified Files: arrays.lisp callbacks.lisp definers.lisp Added Files: ffi-extender.lisp hello-cffi.asd hello-cffi.lpr my-uffi-compat.lisp Log Message: --- /project/cello/cvsroot/hello-c/arrays.lisp 2005/05/23 23:51:57 1.1 +++ /project/cello/cvsroot/hello-c/arrays.lisp 2006/05/15 16:36:13 1.2 @@ -23,7 +23,7 @@ -(in-package :hello-c) +(in-package :ffx) (defparameter *gl-rsrc* nil) @@ -46,7 +46,7 @@ (progn (loop for fgn in *fgn-mem* do (print fgn) - (fgn-free (fgn-ptr fgn)) + (foreign-free (fgn-ptr fgn)) finally (setf *fgn-mem* nil)) (loop for fgn in *gl-rsrc* do (print fgn) @@ -72,11 +72,11 @@ (let ((amt (gensym)) (ptr (gensym))) `(let* ((,amt ,amt-form) - (,ptr (allocate-foreign-object ,type ,amt))) + (,ptr (falloc ,type ,amt))) (call-fgn-alloc ,type ,amt ,ptr (list , at keys))))) (defun call-fgn-alloc (type amt ptr keys) - ;;(print `(fgnalloc ,type ,amt ,keys)) + ;;(print `(call-fgn-alloc ,type ,amt ,keys)) (fgn-ptr (car (push (make-fgn :id keys :type type :amt amt @@ -84,12 +84,14 @@ *fgn-mem*)))) (defun fgn-free (&rest fgn-ptrs) - (loop for fgn-ptr in fgn-ptrs do - (let ((fgn (find fgn-ptr *fgn-mem* :key 'fgn-ptr))) - (if fgn - (setf *fgn-mem* (delete fgn *fgn-mem*)) - (format t "~&Freeing unknown FGN ~a" fgn-ptr)) - (free-foreign-object fgn-ptr)))) + ;; (print `(fgn-free freeing , at fgn-ptrs)) + (let ((start (copy-list fgn-ptrs))) + (loop for fgn-ptr in start do + (let ((fgn (find fgn-ptr *fgn-mem* :key 'fgn-ptr))) + (if fgn + (setf *fgn-mem* (delete fgn *fgn-mem*)) + (format t "~&Freeing unknown FGN ~a" fgn-ptr)) + (foreign-free fgn-ptr))))) (defun gllog (type resource amt &rest keys) (push (make-fgn :id keys @@ -138,7 +140,7 @@ (defun ff-floatv-setf (array &rest floats) (loop for f in floats and n upfrom 0 - do (setf (deref-array array '(:array :float) n) (* 1.0 f))) + do (setf (mem-aref array :float n) (* 1.0 f))) array) ;--------- with-ff-array-elements ------------------------------------------ @@ -147,17 +149,17 @@ (defmacro with-ff-array-elements ((fa type &rest refs) &body body) `(let ,(let ((refn -1)) (mapcar (lambda (ref) - `(,ref (deref-array ,fa '(:array ,type) ,(incf refn)))) + `(,ref (mem-aref ,fa ,type) ,(incf refn))) refs)) , at body)) ;-------- ff-elt --------------------------------------- (defmacro ff-elt-p (v n) - `(deref-array ,v '(:array (* :void)) ,n)) + `(mem-aref ,v :pointer ,n)) (defmacro ff-elt (v type n) - `(deref-array ,v '(:array ,type) ,n)) + `(mem-aref ,v ',type ,n)) (defun elti (v n) (ff-elt v :int n)) @@ -172,10 +174,10 @@ (setf (ff-elt v :float n) (coerce value 'float))) (defun elt$ (v n) - (ff-elt v :cstring n)) + (ff-elt v :string n)) (defun (setf elt$) (value v n) - (setf (ff-elt v :cstring n) value)) + (setf (ff-elt v :string n) value)) (defun eltd (v n) (ff-elt v :double n)) @@ -184,7 +186,7 @@ (setf (ff-elt v :double n) (coerce value 'double-float))) (defmacro fgn-pa (pa n) - `(deref-array ,pa '(:array (* :void)) ,n)) + `(mem-aref ,pa :pointer ,n)) (eval-when (compile load eval) (export '(ffx-reset --- /project/cello/cvsroot/hello-c/callbacks.lisp 2005/05/23 23:51:57 1.1 +++ /project/cello/cvsroot/hello-c/callbacks.lisp 2006/05/15 16:36:13 1.2 @@ -21,8 +21,10 @@ ;;; IN THE SOFTWARE. -(in-package :hello-c) +(in-package :ffx) + +#+precffi (defun ff-register-callable (callback-name) #+allegro (ff:register-foreign-callable callback-name) @@ -33,8 +35,18 @@ (print (list :ff-register-callable-returns cb)) cb)) +(defun ff-register-callable (callback-name) + (let ((known-callback (cffi:get-callback callback-name))) + (assert known-callback) + known-callback)) + +(defmacro ff-defun-callable (call-convention result-type name args &body body) + (declare (ignorable call-convention)) + `(defcallback ,name ,result-type ,args , at body)) + +#+precffi (defmacro ff-defun-callable (call-convention result-type name args &body body) - (declare (ignorable result-type)) + (declare (ignorable call-convention result-type)) (let ((native-args (when args ;; without this p-f-a returns '(:void) as if for declare (process-function-args args)))) #+lispworks @@ -50,35 +62,13 @@ , at body))) -#+test -(ff-defun-callable :cdecl :int square ((arg-1 :int)(data (* :void))) +#+(or) +(ff-defun-callable :cdecl :int square ((arg-1 :int)(data :pointer)) (list data (* arg-1 arg-1))) -(defmacro ff-def-call ((module iname ename) args) - #+cormanlisp - (assert module () "Module (dll name, in fact) required for Corman Lisp") - #+cormanlisp - `(ct:defun-dll ,iname ,args - :return-type :short - :library-name ,module ;; required according Corman doc - :entry-name ,ename - :linkage-type :c) ;; ?? - - #+allegro (declare (ignorable module)) - #+allegro - `(ff:def-foreign-call (,iname ,ename) ,args) - #+lispworks - `(fli:define-foreign-function (,iname ,ename) - ,(mapcar (lambda (arg) (if (listp (cadr arg)) - (list (car arg) (substitute :pointer '* (cadr arg))) - arg)) - args) - :module ,module - :result-type :int)) (eval-when (compile load eval) (export '(ff-register-callable ff-defun-callable - ff-def-call ff-pointer-address))) \ No newline at end of file --- /project/cello/cvsroot/hello-c/definers.lisp 2005/07/10 21:35:01 1.2 +++ /project/cello/cvsroot/hello-c/definers.lisp 2006/05/15 16:36:13 1.3 @@ -20,9 +20,9 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;; $Header: /project/cello/cvsroot/hello-c/definers.lisp,v 1.2 2005/07/10 21:35:01 ktilton Exp $ +;; $Header: /project/cello/cvsroot/hello-c/definers.lisp,v 1.3 2006/05/15 16:36:13 ktilton Exp $ -(in-package :hello-c) +(in-package :ffx) (eval-when (compile load eval) (export '( @@ -46,12 +46,57 @@ ;;; (fli:make-pointer :address n :pointer-type '(:pointer :void))) (defun make-ff-pointer (n) - #+allegro (ff:make-foreign-pointer :address n :type '(* void)) #+lispworks (fli:make-pointer :address n :pointer-type '(:pointer :void)) - #-(or lispworks allegro) n + #+clisp (ffi:unsigned-foreign-address n) + #-(or clisp lispworks) n ) (defmacro defun-ffx (rtn module$ name$ (&rest type-args) &body post-processing) + (declare (ignore module$)) + (let* ((lisp-fn (lisp-fn name$)) + (lispfn (intern (string-upcase name$))) + (var-types (let (args) + (assert (evenp (length type-args)) () "uneven arg-list for ~a" name$) + (dotimes (n (floor (length type-args) 2) (nreverse args)) + (let ((type (elt type-args (* 2 n))) + (var (elt type-args (1+ (* 2 n))))) + (when (eql #\* (elt (symbol-name var) 0)) + ;; no, good with *: (setf var (intern (subseq (symbol-name var) 1))) + (setf type :pointer)) + (push (list var type) args))))) + (cast-vars (mapcar (lambda (var-type) + (copy-symbol (car var-type))) var-types))) + `(progn + (cffi:defcfun (,name$ ,lispfn) ,(if (and (consp rtn) (eq '* (car rtn))) + :pointer rtn) + , at var-types) + + (defun ,lisp-fn ,(mapcar #'car var-types) + (let ,(mapcar (lambda (cast-var var-type) + `(,cast-var ,(if (listp (cadr var-type)) + (car var-type) + (case (cadr var-type) + (:int `(coerce ,(car var-type) 'integer)) + (:long `(coerce ,(car var-type) 'integer)) + (:unsigned-long `(coerce ,(car var-type) 'integer)) + (:unsigned-int `(coerce ,(car var-type) 'integer)) + (:float `(coerce ,(car var-type) 'float)) + (:double `(coerce ,(car var-type) 'double-float)) + (:string (car var-type)) + (:pointer (car var-type)) + (otherwise + (let ((ffc (get (cadr var-type) 'ffi-cast))) + (assert ffc () "Don't know how to cast ~a" (cadr var-type)) + `(coerce ,(car var-type) ',ffc))))))) + cast-vars var-types) + (prog1 + (,lispfn , at cast-vars) + , at post-processing))) + (eval-when (compile eval load) + (export '(,lispfn ,lisp-fn)))))) + +#+precffi +(defmacro defun-ffx (rtn module$ name$ (&rest type-args) &body post-processing) (let* ((lisp-fn (lisp-fn name$)) (lispfn (intern (string-upcase name$))) (var-types (let (args) @@ -81,7 +126,7 @@ (:unsigned-int `(coerce ,(car var-type) 'integer)) (:float `(coerce ,(car var-type) 'float)) (:double `(coerce ,(car var-type) 'double-float)) - (:cstring (car var-type)) + (:string (car var-type)) (otherwise (let ((ffc (get (cadr var-type) 'ffi-cast))) (assert ffc () "Don't know how to cast ~a" (cadr var-type)) @@ -121,7 +166,7 @@ (defmacro dft (ctype ffi-type ffi-cast) `(progn (setf (get ',ctype 'ffi-cast) ',ffi-cast) - (def-foreign-type ,ctype ,ffi-type) + (defctype ,ctype ,ffi-type) (eval-when (compile eval load) (export ',ctype)))) --- /project/cello/cvsroot/hello-c/ffi-extender.lisp 2006/05/15 16:36:13 NONE +++ /project/cello/cvsroot/hello-c/ffi-extender.lisp 2006/05/15 16:36:13 1.1 (in-package :cl-user) (defpackage #:ffi-extender (:nicknames #:ffx) (:shadowing-import-from #:cffi #:with-foreign-object #:load-foreign-library #:with-foreign-string) (:use #:common-lisp #:cffi) (:export #:def-type #:def-foreign-type #:def-constant #:null-char-p #:def-enum #:def-struct #:get-slot-value #:get-slot-pointer #:def-array-pointer #:def-union #:allocate-foreign-object #:with-foreign-object #:with-foreign-objects #:size-of-foreign-type #:pointer-address #:deref-pointer #:ensure-char-character #:ensure-char-integer #:ensure-char-storable #:null-pointer-p #:+null-cstring-pointer+ #:char-array-to-pointer #:with-cast-pointer #:def-foreign-var #:convert-from-cstring #:convert-to-cstring #:free-cstring #:with-cstring #:with-cstrings #:def-function #:find-foreign-library #:load-foreign-library #:default-foreign-library-type #:run-shell-command #:convert-from-foreign-string #:convert-to-foreign-string #:allocate-foreign-string #:with-foreign-string #:foreign-string-length ; not implemented #:convert-from-foreign-usb8 )) (in-package :ffx)--- /project/cello/cvsroot/hello-c/hello-cffi.asd 2006/05/15 16:36:13 NONE +++ /project/cello/cvsroot/hello-c/hello-cffi.asd 2006/05/15 16:36:13 1.1 ;;;; -*- 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))) #-(or openmcl sbcl cmu clisp lispworks ecl allegro cormanlisp) (error "Sorry, this Lisp is not yet supported. Patches welcome!") (asdf:defsystem :hello-cffi :name "Hello CFFI" :author "Kenny Tilton " :version "1.0.0" :maintainer "Kenny Tilton " :licence "Lisp Lesser GNU Public License" :description "CFFI Add-ons" :long-description "Extensions and utilities for CFFI" :depends-on (:cffi :cffi-uffi-compat) :serial t :components ((:file "my-uffi-compat") (:file "ffi-extender") (:file "definers") (:file "arrays") (:file "callbacks"))) --- /project/cello/cvsroot/hello-c/hello-cffi.lpr 2006/05/15 16:36:13 NONE +++ /project/cello/cvsroot/hello-c/hello-cffi.lpr 2006/05/15 16:36:13 1.1 ;; -*- lisp-version: "8.0 [Windows] (May 5, 2006 15:39)"; cg: "1.81"; -*- (in-package :cg-user) (defpackage :HELLO-C) (define-project :name :hello-cffi :modules (list (make-instance 'module :name "my-uffi-compat.lisp") (make-instance 'module :name "ffi-extender.lisp") (make-instance 'module :name "definers.lisp") (make-instance 'module :name "arrays.lisp") (make-instance 'module :name "callbacks.lisp")) :projects (list (make-instance 'project-module :name "C:\\0devtools\\cffi\\cffi")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :hello-c :main-form nil :compilation-unit t :verbose nil :runtime-modules nil :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") :include-flags '(:local-name-info) :build-flags '(:allow-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil :default-command-line-arguments "+cx +t \"Initializing\"" :additional-build-lisp-image-arguments '(:read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard :on-initialization 'default-init-function :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cello/cvsroot/hello-c/my-uffi-compat.lisp 2006/05/15 16:36:13 NONE +++ /project/cello/cvsroot/hello-c/my-uffi-compat.lisp 2006/05/15 16:36:13 1.1 (in-package :cffi) (eval-when (compile load eval) (export '(falloc))) (defun deref-array (array type position) (mem-aref array type position)) (defun (setf deref-array) (value array type position) (setf (mem-aref array type position) value)) (defun falloc (type &optional (size 1)) (cffi:foreign-alloc type :count size)) (defun free-foreign-object (ptr) (foreign-free ptr)) From ktilton at common-lisp.net Wed May 17 04:27:01 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 17 May 2006 00:27:01 -0400 (EDT) Subject: [cello-cvs] CVS hello-cffi Message-ID: <20060517042701.F226B49038@common-lisp.net> Update of /project/cello/cvsroot/hello-cffi In directory clnet:/tmp/cvs-serv16108 Log Message: Status: Vendor Tag: tcvs-vendor Release Tags: tcvs-release No conflicts created by this import From ktilton at common-lisp.net Wed May 17 04:29:42 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 17 May 2006 00:29:42 -0400 (EDT) Subject: [cello-cvs] CVS hello-cffi Message-ID: <20060517042942.53AD04D009@common-lisp.net> Update of /project/cello/cvsroot/hello-cffi In directory clnet:/tmp/cvs-serv16185 Added Files: arrays.lisp callbacks.lisp definers.lisp ffi-extender.lisp hello-cffi.asd hello-cffi.lpr my-uffi-compat.lisp Log Message: --- /project/cello/cvsroot/hello-cffi/arrays.lisp 2006/05/17 04:29:42 NONE +++ /project/cello/cvsroot/hello-cffi/arrays.lisp 2006/05/17 04:29:42 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: hello-c; -*- ;;; ;;; Copyright ? 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (in-package :ffx) (defparameter *gl-rsrc* nil) (defparameter *fgn-mem* nil) (defun fgn-dump () (print (length *fgn-mem*)) (loop for fgn in *fgn-mem* do (print fgn) summing (fgn-amt fgn))) #+check (fgn-dump) (defun ffx-reset (&optional force) (hic-reset force)) (defun hic-reset (&optional force) (if force (progn (loop for fgn in *fgn-mem* do (print fgn) (foreign-free (fgn-ptr fgn)) finally (setf *fgn-mem* nil)) (loop for fgn in *gl-rsrc* do (print fgn) (glfree (fgn-type fgn)(fgn-ptr fgn)) finally (setf *gl-rsrc* nil)) (progn (when *fgn-mem* (loop for fgn in *fgn-mem* do (print fgn) finally (break "above fgn-mem not freed"))) (when *gl-rsrc* (loop for fgn in *gl-rsrc* do (print fgn) finally (break "above *gl-rsrc* not freed"))))))) (defstruct fgn ptr id type amt) (defmethod print-object ((fgn fgn) s) (format s "fgnmem ~a :amt ~a :type ~a" (fgn-id fgn)(fgn-amt fgn)(fgn-type fgn))) (defmacro fgn-alloc (type amt-form &rest keys) (let ((amt (gensym)) (ptr (gensym))) `(let* ((,amt ,amt-form) (,ptr (falloc ,type ,amt))) (call-fgn-alloc ,type ,amt ,ptr (list , at keys))))) (defun call-fgn-alloc (type amt ptr keys) ;;(print `(call-fgn-alloc ,type ,amt ,keys)) (fgn-ptr (car (push (make-fgn :id keys :type type :amt amt :ptr ptr) *fgn-mem*)))) (defun fgn-free (&rest fgn-ptrs) ;; (print `(fgn-free freeing , at fgn-ptrs)) (let ((start (copy-list fgn-ptrs))) (loop for fgn-ptr in start do (let ((fgn (find fgn-ptr *fgn-mem* :key 'fgn-ptr))) (if fgn (setf *fgn-mem* (delete fgn *fgn-mem*)) (format t "~&Freeing unknown FGN ~a" fgn-ptr)) (foreign-free fgn-ptr))))) (defun gllog (type resource amt &rest keys) (push (make-fgn :id keys :type type :amt amt :ptr resource) *gl-rsrc*)) (defun glfree (type resource) (let ((fgn (find (cons type resource) *gl-rsrc* :test 'equal :key (lambda (g) (cons (fgn-type g)(fgn-ptr g)))))) (if fgn (setf *gl-rsrc* (delete fgn *gl-rsrc*)) (format t "~&Freeing unknown GL resource ~a" (cons type resource))) #+nonono (ecase type (:texture (ogl:ogl-texture-delete resource))))) (defmacro make-ff-array (type &rest values) (let ((fv (gensym))(n (gensym))(vs (gensym))) `(let ((,fv (fgn-alloc ',type ,(length values) :make-ff-array)) (,vs (list , at values))) (dotimes (,n ,(length values) ,fv) (setf (ff-elt ,fv ,type ,n) (coerce (nth ,n ,vs) ',(if (keywordp type) (intern (symbol-name type)) (get type 'ffi-cast)))))))) (defmacro ff-list (array type count) (let ((a (gensym))(n (gensym))) `(loop with ,a = ,array for ,n below ,count collecting (ff-elt ,a ,type ,n)))) (defun make-floatv (&rest floats) (let* ((co (fgn-alloc :float (length floats) :make-floatv)) ) (apply 'ff-floatv-setf co floats))) (defmacro ff-floatv-ensure (place &rest values) `(if ,place (ff-floatv-setf ,place , at values) (setf ,place (make-floatv , at values)))) (defun ff-floatv-setf (array &rest floats) (loop for f in floats and n upfrom 0 do (setf (mem-aref array :float n) (* 1.0 f))) array) ;--------- with-ff-array-elements ------------------------------------------ (defmacro with-ff-array-elements ((fa type &rest refs) &body body) `(let ,(let ((refn -1)) (mapcar (lambda (ref) `(,ref (mem-aref ,fa ,type) ,(incf refn))) refs)) , at body)) ;-------- ff-elt --------------------------------------- (defmacro ff-elt-p (v n) `(mem-aref ,v :pointer ,n)) (defmacro ff-elt (v type n) `(mem-aref ,v ',type ,n)) (defun elti (v n) (ff-elt v :int n)) (defun (setf elti) (value v n) (setf (ff-elt v :int n) (coerce value 'integer))) (defun eltf (v n) (ff-elt v :float n)) (defun (setf eltf) (value v n) (setf (ff-elt v :float n) (coerce value 'float))) (defun elt$ (v n) (ff-elt v :string n)) (defun (setf elt$) (value v n) (setf (ff-elt v :string n) value)) (defun eltd (v n) (ff-elt v :double n)) (defun (setf eltd) (value v n) (setf (ff-elt v :double n) (coerce value 'double-float))) (defmacro fgn-pa (pa n) `(mem-aref ,pa :pointer ,n)) (eval-when (compile load eval) (export '(ffx-reset ff-elt ff-list eltf eltd elti fgn-pa with-ff-array-elements make-ff-array make-floatv ff-floatv-ensure hic-reset fgn-alloc fgn-free gllog glfree)))--- /project/cello/cvsroot/hello-cffi/callbacks.lisp 2006/05/17 04:29:42 NONE +++ /project/cello/cvsroot/hello-cffi/callbacks.lisp 2006/05/17 04:29:42 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: hello-c; -*- ;;; ;;; Copyright ? 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (in-package :ffx) #+precffi (defun ff-register-callable (callback-name) #+allegro (ff:register-foreign-callable callback-name) #+lispworks (let ((cb (progn ;; fli:pointer-address (fli:make-pointer :symbol-name (symbol-name callback-name) ;; leak? :functionp t)))) (print (list :ff-register-callable-returns cb)) cb)) (defun ff-register-callable (callback-name) (let ((known-callback (cffi:get-callback callback-name))) (assert known-callback) known-callback)) (defmacro ff-defun-callable (call-convention result-type name args &body body) (declare (ignorable call-convention)) `(defcallback ,name ,result-type ,args , at body)) #+precffi (defmacro ff-defun-callable (call-convention result-type name args &body body) (declare (ignorable call-convention result-type)) (let ((native-args (when args ;; without this p-f-a returns '(:void) as if for declare (process-function-args args)))) #+lispworks `(fli:define-foreign-callable (,(symbol-name name) :result-type ,result-type :calling-convention ,call-convention) (, at native-args) , at body) #+allegro `(ff:defun-foreign-callable ,name ,native-args (declare (:convention ,(ecase call-convention (:cdecl :c) (:stdcall :stdcall)))) , at body))) #+(or) (ff-defun-callable :cdecl :int square ((arg-1 :int)(data :pointer)) (list data (* arg-1 arg-1))) (eval-when (compile load eval) (export '(ff-register-callable ff-defun-callable ff-pointer-address)))--- /project/cello/cvsroot/hello-cffi/definers.lisp 2006/05/17 04:29:42 NONE +++ /project/cello/cvsroot/hello-cffi/definers.lisp 2006/05/17 04:29:42 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: hello-c; -*- ;;; ;;; Copyright ? 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. ;; $Header: /project/cello/cvsroot/hello-cffi/definers.lisp,v 1.1 2006/05/17 04:29:42 ktilton Exp $ (in-package :ffx) (eval-when (compile load eval) (export '( defun-ffx defun-ffx-multi dffr dfc dft dfenum make-ff-pointer ff-pointer-address ))) (defun ff-pointer-address (ff-ptr) #-lispworks ff-ptr #+lispworks (fli:pointer-address ff-ptr)) ;;;(defun make-ff-pointer (n) ;;; #-lispworks ;;; n ;;; #+lispworks ;;; (fli:make-pointer :address n :pointer-type '(:pointer :void))) (defun make-ff-pointer (n) #+lispworks (fli:make-pointer :address n :pointer-type '(:pointer :void)) #+clisp (ffi:unsigned-foreign-address n) #-(or clisp lispworks) n ) (defmacro defun-ffx (rtn module$ name$ (&rest type-args) &body post-processing) (declare (ignore module$)) (let* ((lisp-fn (lisp-fn name$)) (lispfn (intern (string-upcase name$))) (var-types (let (args) (assert (evenp (length type-args)) () "uneven arg-list for ~a" name$) (dotimes (n (floor (length type-args) 2) (nreverse args)) (let ((type (elt type-args (* 2 n))) (var (elt type-args (1+ (* 2 n))))) (when (eql #\* (elt (symbol-name var) 0)) ;; no, good with *: (setf var (intern (subseq (symbol-name var) 1))) (setf type :pointer)) (push (list var type) args))))) (cast-vars (mapcar (lambda (var-type) (copy-symbol (car var-type))) var-types))) `(progn (cffi:defcfun (,name$ ,lispfn) ,(if (and (consp rtn) (eq '* (car rtn))) :pointer rtn) , at var-types) (defun ,lisp-fn ,(mapcar #'car var-types) (let ,(mapcar (lambda (cast-var var-type) `(,cast-var ,(if (listp (cadr var-type)) (car var-type) (case (cadr var-type) (:int `(coerce ,(car var-type) 'integer)) (:long `(coerce ,(car var-type) 'integer)) (:unsigned-long `(coerce ,(car var-type) 'integer)) (:unsigned-int `(coerce ,(car var-type) 'integer)) (:float `(coerce ,(car var-type) 'float)) (:double `(coerce ,(car var-type) 'double-float)) (:string (car var-type)) (:pointer (car var-type)) (otherwise (let ((ffc (get (cadr var-type) 'ffi-cast))) (assert ffc () "Don't know how to cast ~a" (cadr var-type)) `(coerce ,(car var-type) ',ffc))))))) cast-vars var-types) (prog1 (,lispfn , at cast-vars) , at post-processing))) (eval-when (compile eval load) (export '(,lispfn ,lisp-fn)))))) #+precffi (defmacro defun-ffx (rtn module$ name$ (&rest type-args) &body post-processing) (let* ((lisp-fn (lisp-fn name$)) (lispfn (intern (string-upcase name$))) (var-types (let (args) (assert (evenp (length type-args)) () "uneven arg-list for ~a" name$) (dotimes (n (floor (length type-args) 2) (nreverse args)) (let ((type (elt type-args (* 2 n))) (var (elt type-args (1+ (* 2 n))))) (when (eql #\* (elt (symbol-name var) 0)) ;; no, good with *: (setf var (intern (subseq (symbol-name var) 1))) (setf type `(* ,type))) (push (list var type) args))))) (cast-vars (mapcar (lambda (var-type) (copy-symbol (car var-type))) var-types))) `(progn (def-function (,name$ ,lispfn) ,var-types :returning ,rtn :module ,module$) (defun ,lisp-fn ,(mapcar #'car var-types) (let ,(mapcar (lambda (cast-var var-type) `(,cast-var ,(if (listp (cadr var-type)) (car var-type) (case (cadr var-type) (:int `(coerce ,(car var-type) 'integer)) (:long `(coerce ,(car var-type) 'integer)) (:unsigned-long `(coerce ,(car var-type) 'integer)) (:unsigned-int `(coerce ,(car var-type) 'integer)) (:float `(coerce ,(car var-type) 'float)) (:double `(coerce ,(car var-type) 'double-float)) [59 lines skipped] --- /project/cello/cvsroot/hello-cffi/ffi-extender.lisp 2006/05/17 04:29:42 NONE +++ /project/cello/cvsroot/hello-cffi/ffi-extender.lisp 2006/05/17 04:29:42 1.1 [110 lines skipped] --- /project/cello/cvsroot/hello-cffi/hello-cffi.asd 2006/05/17 04:29:42 NONE +++ /project/cello/cvsroot/hello-cffi/hello-cffi.asd 2006/05/17 04:29:42 1.1 [134 lines skipped] --- /project/cello/cvsroot/hello-cffi/hello-cffi.lpr 2006/05/17 04:29:42 NONE +++ /project/cello/cvsroot/hello-cffi/hello-cffi.lpr 2006/05/17 04:29:42 1.1 [171 lines skipped] --- /project/cello/cvsroot/hello-cffi/my-uffi-compat.lisp 2006/05/17 04:29:42 NONE +++ /project/cello/cvsroot/hello-cffi/my-uffi-compat.lisp 2006/05/17 04:29:42 1.1 [187 lines skipped] From ktilton at common-lisp.net Wed May 17 16:05:42 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 17 May 2006 12:05:42 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-ftgl Message-ID: <20060517160542.AF6D75C125@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-ftgl In directory clnet:/tmp/cvs-serv20164/cl-ftgl Log Message: Directory /project/cello/cvsroot/cello/cl-ftgl added to the repository From ktilton at common-lisp.net Wed May 17 16:07:23 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 17 May 2006 12:07:23 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-magick Message-ID: <20060517160723.DA2436302D@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-magick In directory clnet:/tmp/cvs-serv20661/cl-magick Log Message: Directory /project/cello/cvsroot/cello/cl-magick added to the repository From ktilton at common-lisp.net Wed May 17 16:07:24 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 17 May 2006 12:07:24 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-openal Message-ID: <20060517160724.1722C64106@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-openal In directory clnet:/tmp/cvs-serv20661/cl-openal Log Message: Directory /project/cello/cvsroot/cello/cl-openal added to the repository From ktilton at common-lisp.net Wed May 17 16:07:24 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 17 May 2006 12:07:24 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-opengl Message-ID: <20060517160724.4C4C664106@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-opengl In directory clnet:/tmp/cvs-serv20661/cl-opengl Log Message: Directory /project/cello/cvsroot/cello/cl-opengl added to the repository From ktilton at common-lisp.net Wed May 17 16:12:37 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 17 May 2006 12:12:37 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-ftgl/ftgl-int Message-ID: <20060517161237.2DBC122004@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-ftgl/ftgl-int In directory clnet:/tmp/cvs-serv22541/ftgl-int Log Message: Directory /project/cello/cvsroot/cello/cl-ftgl/ftgl-int added to the repository From ktilton at common-lisp.net Wed May 17 16:14:28 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 17 May 2006 12:14:28 -0400 (EDT) Subject: [cello-cvs] CVS cello/cellodemo Message-ID: <20060517161428.F0F6C30015@common-lisp.net> Update of /project/cello/cvsroot/cello/cellodemo In directory clnet:/tmp/cvs-serv22618/cellodemo Modified Files: cellodemo.lisp cellodemo.lpr demo-window.lisp light-panel.lisp Log Message: CVS re-organization bringing auxiliary packages under one Cello module --- /project/cello/cvsroot/cello/cellodemo/cellodemo.lisp 2005/07/05 17:00:29 1.1 +++ /project/cello/cvsroot/cello/cellodemo/cellodemo.lisp 2006/05/17 16:14:28 1.2 @@ -23,7 +23,7 @@ (in-package :cello) -#+test +#+(or) (list (demo-image-subdir "shapers") (demo-image-subdir)) --- /project/cello/cvsroot/cello/cellodemo/cellodemo.lpr 2005/07/05 17:00:29 1.1 +++ /project/cello/cvsroot/cello/cellodemo/cellodemo.lpr 2006/05/17 16:14:28 1.2 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "7.0 [Windows] (May 6, 2005 8:25)"; cg: "1.54.2.17"; -*- +;; -*- lisp-version: "7.0 [Windows] (Aug 5, 2005 12:23)"; cg: "1.54.2.17"; -*- (in-package :cg-user) --- /project/cello/cvsroot/cello/cellodemo/demo-window.lisp 2005/07/05 17:00:29 1.1 +++ /project/cello/cvsroot/cello/cellodemo/demo-window.lisp 2006/05/17 16:14:28 1.2 @@ -128,7 +128,7 @@ :ambient *dusk* :diffuse *dim* :specular *bright*)) - :recording nil #+not (c? (when (md-value (fm-other :record)) + :recording nil #+(or) (c? (when (md-value (fm-other :record)) (make-recording :wand (magick-wand-template) :splice-wand (magick-wand-template) @@ -264,6 +264,7 @@ (setf (snapshot-release-id .w.) (incf snap-count)))))))) + (defun texture-picker (&aux (backdrops (directory (demo-image-subdir "window-bkgs")))) --- /project/cello/cvsroot/cello/cellodemo/light-panel.lisp 2005/07/05 17:00:29 1.1 +++ /project/cello/cvsroot/cello/cellodemo/light-panel.lisp 2006/05/17 16:14:28 1.2 @@ -203,7 +203,7 @@ (defmodel ix-light (light ix-stack) ((initial-pos :initarg :initial-pos :initform nil :accessor initial-pos)) (:default-initargs - :md-value nil #+not (c? (when (md-value (fm-other :enabled)) + :md-value nil #+(or) (c? (when (md-value (fm-other :enabled)) (make-instance 'light :id id))) :enabled (c? (md-value (fm-other :enabled))) @@ -266,4 +266,4 @@ (make-rgba-mixer :diffuse)) (a-stack (:justify :right :visible nil :collapsed t) (alabel "specular") - (make-rgba-mixer :specular)))))) \ No newline at end of file + (make-rgba-mixer :specular)))))) From ktilton at common-lisp.net Wed May 17 16:14:29 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 17 May 2006 12:14:29 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-ftgl Message-ID: <20060517161429.2FBB330016@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-ftgl In directory clnet:/tmp/cvs-serv22618/cl-ftgl Added Files: cl-ftgl.lisp cl-ftgl.lpr Log Message: CVS re-organization bringing auxiliary packages under one Cello module --- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2006/05/17 16:14:29 NONE +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2006/05/17 16:14:29 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*- ;;; ;;; Copyright ? 2004 by Kenneth William Tilton. ;;;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. ;;; $Header: /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp,v 1.1 2006/05/17 16:14:29 ktilton Exp $ (defpackage #:cl-ftgl (:nicknames #:ftgl) (:use #:common-lisp #:cffi #:cl-opengl) (:export #:ftgl #:ftgl-pixmap #:ftgl-texture #:ftgl-bitmap #:ftgl-polygon #:ftgl-extruded #:ftgl-outline #:ftgl-string-length #:ftgl-get-ascender #:ftgl-get-descender #:ftgl-make #:cl-ftgl-init #:cl-ftgl-reset #:xftgl #:ftgl-render #:ftgl-font-ensure #:*ftgl-dynamic-lib-path* #:*font-directory-path* #:*gui-style-default-face* #:*gui-style-button-face*)) (in-package :cl-ftgl) (define-foreign-library FTGL (:darwin (:framework "FTGL")) (:windows (:or "/0dev/user/dynlib/ftgl_dynamic_MTD_d.dll"))) (use-foreign-library FTGL) (defparameter *gui-style-default-face* 'sylfaen) (defparameter *ftgl-loaded-p* nil) (defparameter *ftgl-fonts-loaded* nil) ;; ---------------------------------------------------------------------------- ;; FOREIGN FUNCTION INTERFACE ;; ---------------------------------------------------------------------------- (defcfun ("fgcSetFaceSize" fgc-set-face-size) :unsigned-char (f :pointer)(size :int)(res :int)) (defcfun ("fgcCharTexture" fgc-char-texture) :int (f :pointer)(charCode :int)) (defcfun ("fgcAscender" fgc-ascender) :float (font :pointer)) (defcfun ("fgcDescender" fgc-descender) :float (font :pointer)) (defcfun ("fgcStringAdvance" fgc-string-advance) :float (font :pointer) (text :string)) (defcfun ("fgcStringX" fgc-string-x) :float (font :pointer)(text :string)) (defcfun ("fgcRender" fgc-render) :void (font :pointer)(text :string)) (defcfun ("fgcBuildGlyphs" fgc-build-glyphs) :void (font :pointer)) (defcfun ("fgcFree" fgc-free) :void (font :pointer)) (defcfun ("fgcBitmapMake" fgc-bitmap-make) :pointer (typeface :string)) (defcfun ("fgcPixmapMake" fgc-pixmap-make) :pointer (typeface :string)) (defcfun ("fgcTextureMake" fgc-texture-make) :pointer (typeface :string)) (defcfun ("fgcPolygonMake" fgc-polygon-make) :pointer (typeface :string)) (defcfun ("fgcOutlineMake" fgc-outline-make) :pointer (typeface :string)) (defcfun ("fgcExtrudedMake" fgc-extruded-make) :pointer (typeface :string)) (defcfun ("fgcSetFaceDepth" fgcSetFaceDepth) :unsigned-char (font :pointer)(depth :float)) (defun fgc-set-face-depth (font depth) (fgcSetFaceDepth font (coerce depth 'float))) (defparameter *font-directory-path* (make-pathname :directory #+(or win32 mswindows) '(:absolute "windows" "fonts") #+linux '(:absolute "usr" "share" "fonts" "truetype") #+darwin '(:absolute "Library" "Fonts"))) ;; ---------------------------------------------------------------------------- ;; FUNCTIONS/METHODS ;; ---------------------------------------------------------------------------- (defun cl-ftgl-reset () #-mcl (setq *ftgl-loaded-p* nil) (setq *ftgl-fonts-loaded* nil)) #+test (progn (cl-ftgl-init) (let ((sylfaen (ftgl-font-ensure :texture "Sylfaen" 24 96))) (print (list "sylfaen ascender" (ftgl-get-ascender sylfaen))) (print (list "sylfaen descender" (ftgl-get-descender sylfaen))) (print (list "sylfaen hello world length" (ftgl-string-length sylfaen "Hello world"))) (print (list "sylfaen disp font" (ftgl-get-display-font sylfaen))) )) (defun cl-ftgl-init () (unless *ftgl-loaded-p* (assert (setq *ftgl-loaded-p* (use-foreign-library ftgl))))) (defun ftgl-font-ensure (type face size target-res &optional (depth 0)) (let ((fspec (list type face size target-res depth))) (or (cdr (assoc fspec *ftgl-fonts-loaded* :test 'equal)) (let ((f (apply 'ftgl-make fspec))) (push (cons fspec f) *ftgl-fonts-loaded*) f)))) (defun ftgl-make (type face size target-res &optional (depth 0)) ;; (print (list "ftgl-make entry" type face size)) (funcall (ecase type (:bitmap 'make-ftgl-bitmap) (:pixmap 'make-ftgl-pixmap) (:texture 'make-ftgl-texture) (:outline 'make-ftgl-outline) (:polygon 'make-ftgl-polygon) (:extruded 'make-ftgl-extruded)) :face face :size size :target-res target-res :depth depth)) ;; --------- ftgl structure ----------------- (defstruct ftgl face size target-res depth descender ascender bboxes ifont) (defstruct (ftgl-disp (:include ftgl)) ready-p) (defstruct (ftgl-pixmap (:include ftgl-disp))) (defstruct (ftgl-texture (:include ftgl-disp))) (defstruct (ftgl-bitmap (:include ftgl))) (defstruct (ftgl-polygon (:include ftgl))) (defstruct (ftgl-extruded (:include ftgl-disp))) (defstruct (ftgl-outline (:include ftgl))) (defmethod ftgl-ready (font) (declare (ignorable font)) t) (defmethod (setf ftgl-ready) (new-value (font ftgl-disp)) (setf (ftgl-disp-ready-p font) new-value)) (defmethod (setf ftgl-ready) (new-value font) (declare (ignore new-value font))) (defmethod ftgl-ready ((font ftgl-disp)) ;(print (list "A cheerful HELLO from ftgl-ready: " font)) (ftgl-disp-ready-p font)) #+allegro (defun xftgl () (dolist (dll (ff:list-all-foreign-libraries)) (when (search "ftgl" (pathname-name dll)) (print `(unloading foreign library ,dll)) (ff:unload-foreign-library dll) (cl-ftgl-reset)))) (defun ftgl-get-ascender (font) (or (ftgl-ascender font) (setf (ftgl-ascender font) (fgc-ascender (ftgl-get-metrics-font font))))) (defun ftgl-get-descender (font) (or (ftgl-descender font) (setf (ftgl-descender font) (fgc-descender (ftgl-get-metrics-font font))))) (defun ftgl-get-display-font (font) (let ((cf (ftgl-get-metrics-font font))) (assert cf) ; (print (list "FTGL-GET-DISPLAY-FONT sees" (ftgl-disp-ready-p font))) ;; (print (list "FTGL-GET-DISPLAY-FONT sees" (ftgl-ready font))) (Unless (ftgl-ready font) ; (when *ogl-listing-p* ; (cells::c-break "bad time #1 for sizing? ~a ~a" *ogl-listing-p* font)) (setf (ftgl-ready font) t) (typecase font (ftgl-extruded #+nyet (let ((*ogl-listing-p* t)) (ukt::trc nil "ftgl-get-display-font> building glyphs for" font) (fgc-build-glyphs cf) (ukt::trc nil "ftgl-get-display-font> glyphs built OK for" font))) (ftgl-texture #+no (fgc-set-face-size cf (ftgl-size font) (ftgl-target-res font))) (ftgl-pixmap #+no (fgc-set-face-size cf (ftgl-size font) (ftgl-target-res font))))) cf)) (defun ftgl-get-metrics-font (font) (prog1 (or (ftgl-ifont font) (setf (ftgl-ifont font) (ftgl-font-make font))) ;; (print (list "ftgl-get-metrics-font: exit" font)) ; frgo, ADDED: debug... )) (defun ftgl-font-make (font) ;; (print (list "ftgl-font-make: entry" font)) (let ((path (merge-pathnames (make-pathname :name (string (ftgl-face font)) :type "ttf") *font-directory-path*))) (if (probe-file path) (let* ((fpath (namestring path)) (f (fgc-font-make font fpath))) (if f (progn ;;(ogl::dump-lists 1 10000) (fgc-set-face-size f (ftgl-size font) (ftgl-target-res font)) f) (error "cannot load ~a font ~a" (type-of font) fpath))) (error "Font not found: ~a" path)))) (defun ftgl-render (font s) (assert font) (assert (stringp s)) (when font (let ((df (ftgl-get-display-font font))) (if df (fgc-render df s) (break "whoa, no display font for ~a" font))))) (defmethod fgc-font-make :before (font fpath) (declare (ignore font fpath)) (cl-ftgl-init)) (defmethod fgc-font-make ((font ftgl-pixmap) fpath) (fgc-pixmap-make fpath)) (defmethod fgc-font-make ((font ftgl-bitmap) fpath) (fgc-bitmap-make fpath)) (defmethod fgc-font-make ((font ftgl-texture) fpath) (fgc-texture-make fpath)) (defmethod fgc-font-make ((font ftgl-extruded) fpath) (let ((fgc (fgc-extruded-make fpath))) (fgc-set-face-depth fgc (ftgl-depth font)) fgc)) (defmethod fgc-font-make ((font ftgl-outline) fpath) (fgc-outline-make fpath)) (defmethod fgc-font-make ((font ftgl-polygon) fpath) (fgc-polygon-make fpath)) (defun ftgl-string-length (font cs) (fgc-string-advance (ftgl-get-metrics-font font) cs)) (defmethod font-bearing-x ((font ftgl) &optional (text "m")) (fgc-string-x (ftgl-get-metrics-font font) text)) (defmethod font-bearing-x (font &optional text) (declare (ignorable font text)) 0) --- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2006/05/17 16:14:29 NONE +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2006/05/17 16:14:29 1.1 ;; -*- lisp-version: "8.0 [Windows] (Apr 21, 2006 10:24)"; cg: "1.81"; -*- (in-package :cg-user) (defpackage :CL-FTGL) (define-project :name :cl-ftgl :modules (list (make-instance 'module :name "cl-ftgl.lisp")) :projects (list (make-instance 'project-module :name "C:\\0devtools\\cl-opengl\\cl-opengl")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :cl-ftgl :main-form nil :compilation-unit t :verbose nil :runtime-modules '(:cg-dde-utils :cg.base :cg.bitmap-pane :cg.bitmap-pane.clipboard :cg.bitmap-stream :cg.button :cg.caret :cg.check-box :cg.choice-list :cg.choose-printer :cg.clipboard :cg.clipboard-stack :cg.clipboard.pixmap :cg.color-dialog :cg.combo-box :cg.common-control :cg.comtab :cg.cursor-pixmap :cg.curve :cg.dialog-item :cg.directory-dialog :cg.directory-dialog-os :cg.drag-and-drop :cg.drag-and-drop-image :cg.drawable :cg.drawable.clipboard :cg.dropping-outline :cg.edit-in-place :cg.editable-text :cg.file-dialog :cg.fill-texture :cg.find-string-dialog :cg.font-dialog :cg.gesture-emulation :cg.get-pixmap :cg.get-position :cg.graphics-context :cg.grid-widget :cg.grid-widget.drag-and-drop :cg.group-box :cg.header-control :cg.hotspot :cg.html-dialog :cg.html-widget :cg.icon :cg.icon-pixmap :cg.ie :cg.item-list :cg.keyboard-shortcuts :cg.lamp :cg.lettered-menu :cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget :cg.list-view :cg.mci :cg.menu :cg.menu.tooltip :cg.message-dialog :cg.multi-line-editable-text :cg.multi-line-lisp-text :cg.multi-picture-button :cg.multi-picture-button.drag-and-drop :cg.multi-picture-button.tooltip :cg.ocx :cg.os-widget :cg.os-window :cg.outline :cg.outline.drag-and-drop :cg.outline.edit-in-place :cg.palette :cg.paren-matching :cg.picture-widget :cg.picture-widget.palette :cg.pixmap :cg.pixmap-widget :cg.pixmap.file-io :cg.pixmap.printing :cg.pixmap.rotate :cg.printing :cg.progress-indicator :cg.project-window :cg.property :cg.radio-button :cg.rich-edit :cg.rich-edit-pane :cg.rich-edit-pane.clipboard :cg.rich-edit-pane.printing :cg.sample-file-menu :cg.scaling-stream :cg.scroll-bar :cg.scroll-bar-mixin :cg.selected-object :cg.shortcut-menu :cg.static-text :cg.status-bar :cg.string-dialog :cg.tab-control :cg.template-string :cg.text-edit-pane :cg.text-edit-pane.file-io :cg.text-edit-pane.mark :cg.text-or-combo :cg.text-widget :cg.timer :cg.toggling-widget :cg.toolbar :cg.tooltip :cg.trackbar :cg.tray :cg.up-down-control :cg.utility-dialog :cg.web-browser :cg.web-browser.dde :cg.wrap-string :cg.yes-no-list :cg.yes-no-string :dde) :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") :include-flags '(:compiler :top-level :local-name-info) :build-flags '(:allow-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil :default-command-line-arguments "+cx +t \"Initializing\"" :additional-build-lisp-image-arguments '(:read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard :on-initialization 'cl-ftgl::cl-ftgl-test :on-restart 'do-default-restart) ;; End of Project Definition From ktilton at common-lisp.net Wed May 17 16:14:29 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 17 May 2006 12:14:29 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-ftgl/ftgl-int Message-ID: <20060517161429.612AC30015@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-ftgl/ftgl-int In directory clnet:/tmp/cvs-serv22618/cl-ftgl/ftgl-int Added Files: FTGLFromC.cpp fgc.def Log Message: CVS re-organization bringing auxiliary packages under one Cello module --- /project/cello/cvsroot/cello/cl-ftgl/ftgl-int/FTGLFromC.cpp 2006/05/17 16:14:29 NONE +++ /project/cello/cvsroot/cello/cl-ftgl/ftgl-int/FTGLFromC.cpp 2006/05/17 16:14:29 1.1 #include /* ;;; ;;; Copyright ? 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. */ #include "FTGLBitmapFont.h" #include "FTBitmapGlyph.h" #include "FTGLPixmapFont.h" #include "FTPixmapGlyph.h" #include "FTGLTextureFont.h" #include "FTTextureGlyph.h" #include "FTGlyphContainer.h" #include "FTBBox.h" #include "FTGLPolygonFont.h" #include "FTPolyGlyph.h" #include "FTGLOutlineFont.h" #include "FTOutlineGlyph.h" #include "FTGLExtrdFont.h" #include "FTExtrdGlyph.h" extern "C" { void __stdcall fgcBuildGlyphs( FTFont* f ) { f->BuildGlyphs(); } bool __stdcall fgcSetFaceSize( FTFont* f , unsigned int faceSize , unsigned int res ) { return f->FaceSize( faceSize, res ); } float __stdcall fgcAscender( FTFont* f ) { return f->Ascender( ); } float __stdcall fgcDescender( FTFont* f ) { return f->Descender( ); } float __stdcall fgcStringAdvance( FTFont* f, const char* string ) { return f->Advance( string ); } int __stdcall fgcCharTexture( FTFont* f, int chr ) { return ((FTGlyph *) f->FontGlyph( chr ))->glRendering(); //return f->GlyphRendering( chr ); } /* void FTFont::DoRender( const unsigned int chr, const unsigned int nextChr) { CheckGlyph( chr); FTPoint kernAdvance = glyphList->Render( chr, nextChr, pen); pen.x += kernAdvance.x; pen.y += kernAdvance.y; }*/ float __stdcall fgcStringX( FTFont* f, const char* string ) { float llx,lly,llz,urx,ury,urz; f->BBox( string, llx, lly, llz, urx, ury, urz ); return llx; } void __stdcall fgcRender( FTFont* f, const char *string ) { f->Render( string ); } void __stdcall fgcFree( FTFont* f ) { delete f; } //--------- Bitmap ---------------------------------------------- FTGLBitmapFont* __stdcall fgcBitmapMake( const char* fontname ) { return new FTGLBitmapFont( fontname ); } //--------- Pixmap ---------------------------------------------- FTGLPixmapFont* __stdcall fgcPixmapMake( const char* fontname ) { return new FTGLPixmapFont( fontname ); } //--------- Texture ---------------------------------------------- FTGLTextureFont* __stdcall fgcTextureMake( const char* fontname ) { return new FTGLTextureFont( fontname ); } //--------- Polygon ---------------------------------------------- FTGLPolygonFont* __stdcall fgcPolygonMake( const char* fontname ) { return new FTGLPolygonFont( fontname ); } //--------- Outline ---------------------------------------------- FTGLOutlineFont* __stdcall fgcOutlineMake( const char* fontname ) { return new FTGLOutlineFont( fontname ); } //--------- Extruded Polygon ------------------------------------- FTGLExtrdFont* __stdcall fgcExtrudedMake( const char* fontname ) { return new FTGLExtrdFont( fontname ); } bool __stdcall fgcSetFaceDepth( FTGLExtrdFont* f , float depth ) { f->Depth( depth ); return true; } } --- /project/cello/cvsroot/cello/cl-ftgl/ftgl-int/fgc.def 2006/05/17 16:14:29 NONE +++ /project/cello/cvsroot/cello/cl-ftgl/ftgl-int/fgc.def 2006/05/17 16:14:29 1.1 DESCRIPTION 'C Interface to FTGL' VERSION 0.1 EXPORTS fgcSetFaceSize fgcCharTexture fgcStringX fgcAscender fgcDescender fgcStringAdvance fgcRender fgcFree fgcBitmapMake fgcPixmapMake fgcTextureMake fgcPolygonMake fgcOutlineMake fgcExtrudedMake fgcSetFaceDepth fgcBuildGlyphs From ktilton at common-lisp.net Wed May 17 16:14:29 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 17 May 2006 12:14:29 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-magick Message-ID: <20060517161429.A742E30016@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-magick In directory clnet:/tmp/cvs-serv22618/cl-magick Added Files: build.lisp cl-magick.asd cl-magick.lisp cl-magick.lpr drawing-wand.lisp magick-wand.lisp mgk-utils.lisp pixel-wand.lisp wand-image.lisp wand-pixels.lisp wand-texture.lisp Log Message: CVS re-organization bringing auxiliary packages under one Cello module --- /project/cello/cvsroot/cello/cl-magick/build.lisp 2006/05/17 16:14:29 NONE +++ /project/cello/cvsroot/cello/cl-magick/build.lisp 2006/05/17 16:14:29 1.1 (in-package :cl-user) #-allegro-ide (let ((drive "C") (d-force nil)) (build-sys d-force drive "dvx" "uffi") (build-sys d-force drive "dvx" "ffi-extender") (build-sys d-force drive "dvx" "cl-opengl") (load (dev-root "cl-ftgl" "cl-ftgl.lisp")) (build-sys d-force drive "dvx" "cl-magick") ; (cl-magick::cl-magick-test) ) #+test (cl-magick::cl-magick-test) (in-package :cl-user) #-allegro-ide (let ((drive "C") (d-force nil)) (build-sys d-force drive "dvx" "uffi") (build-sys d-force drive "dvx" "ffi-extender") (build-sys d-force drive "dvx" "cl-opengl") (load (dev-root "cl-ftgl" "cl-ftgl.lisp")) (build-sys d-force drive "dvx" "cl-magick") ; (cl-magick::cl-magick-test) ) #+test (cl-magick::cl-magick-test) --- /project/cello/cvsroot/cello/cl-magick/cl-magick.asd 2006/05/17 16:14:29 NONE +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.asd 2006/05/17 16:14:29 1.1 ;;;; -*- 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))) (in-package :asdf) #+(or allegro lispworks cmu mcl cormanlisp sbcl scl) (defsystem cl-magick :name "cl-magick" :author "Kenny Tilton " :version "1.0.0" :maintainer "Kenny Tilton " :licence "MIT" :description "Bindings for ImageMagick" :long-description "Poorly implemented bindings to half of ImageMagick" :components ((:file "cl-magick") (:file "magick-wand" :depends-on ("cl-magick")) (:file "drawing-wand" :depends-on ("magick-wand")) (:file "pixel-wand" :depends-on ("drawing-wand")) (:file "mgk-utils" :depends-on ("pixel-wand")) (:file "wand-image" :depends-on ("mgk-utils")) (:file "wand-texture" :depends-on ("wand-image")) (:file "wand-pixels" :depends-on ("wand-texture")) (:file "mgk-test" :depends-on ("wand-pixels")))) --- /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2006/05/17 16:14:29 NONE +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2006/05/17 16:14:29 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-magick; -*- ;;; ;;; Copyright ? 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (defpackage :cl-magick (:nicknames :mgk) (:use #:common-lisp #-(or cormanlisp ccl) #:clos #:hello-c #:ffx #+cl-opengl #:cl-opengl ;; wands as opengl textures ) (:export #:wand-manager #:wand-ensure-typed #:wands-clear #:wand-pixels #:wand-texture #:wand-render #:image-size #:wand-texture-activate #:xim #:magick-get-image-width #:magick-get-image-height #:magick-get-image-pixels #:new-magick-wand #:magick-read-image #:magick-flip-image #:wand-get-image-pixels #:path-to-wand #:mgk-wand-images-write #:magick-wand-template)) (eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :cl-magick *features*)) (in-package :cl-magick) (defun magick-wand-template () (path-to-wand (make-pathname :directory '(:absolute "0dev" "user" "graphics" "templates") :name "metal" :type "gif"))) (defparameter *imagick-dll-loaded* nil) (defparameter *wands-loaded* nil) (defparameter *mgk-version* (fgn-alloc :unsigned-long 1)) (cffi:define-foreign-library Magick (:darwin (:framework "GraphicsMagick")) (:windows (:or #+not "C:\\Program Files\\ImageMagick-6.2.7-Q8\\CORE_RL_wand_.dll" "C:\\Program Files\\GraphicsMagick-1.1.7-Q8\\CORE_RL_wand_.dll"))) (eval-when (load eval) (cffi:use-foreign-library magick)) ;------------------------------------------------------------------- (defun cl-magick-init () (or *imagick-dll-loaded* (progn ;(print "clearing magick wands") ;(wands-clear) (assert (setq *imagick-dll-loaded* t #+not (cffi:use-foreign-library magick)) () "Unable to load imagick" ) (print `(magick-copyright ,(magick-get-copyright))) (print `(magick-version ,(magick-get-version *mgk-version*))) *imagick-dll-loaded*))) #+test (cl-magick-init) (defun wands-loaded () *wands-loaded*) (DEFUN (setf wands-loaded) (new-value) (setf *wands-loaded* new-value)) (defun wands-clear () (loop for wand in *wands-loaded* do (wand-release (cdr wand))) (setf *wands-loaded* nil)) (defun wand-ensure-typed (wand-type file-path$ &rest iargs) (when file-path$ (cl-magick-init) (let ((key (list* wand-type (namestring file-path$) iargs))) (or (let ((old nil #+nope (cdr (assoc key (wands-loaded) :test 'equal)))) ;;/// primitive test (when old (print `(wand-ensure-typed re-using prior load ,wand-type ,file-path$))) old) (let ((wi (apply 'make-instance wand-type :file-path$ file-path$ iargs))) (print `(wand-ensure-typed forced to load ,wand-type ,file-path$)) (push (cons key wi) (wands-loaded)) wi) (error "Unable to load image file ~a" file-path$))))) #+allegro (defun xim () (wands-clear) (dolist (dll (ff:list-all-foreign-libraries)) (when (search "wand" (pathname-name dll)) (print `(unloading foreign library ,dll)) (setf *imagick-dll-loaded* nil) (ff:unload-foreign-library dll)))) --- /project/cello/cvsroot/cello/cl-magick/cl-magick.lpr 2006/05/17 16:14:29 NONE +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lpr 2006/05/17 16:14:29 1.1 ;; -*- lisp-version: "8.0 [Windows] (May 5, 2006 15:39)"; cg: "1.81"; -*- (in-package :cg-user) (defpackage :CL-MAGICK) (define-project :name :cl-magick :modules (list (make-instance 'module :name "cl-magick.lisp") (make-instance 'module :name "magick-wand.lisp") (make-instance 'module :name "drawing-wand.lisp") (make-instance 'module :name "pixel-wand.lisp") (make-instance 'module :name "mgk-utils.lisp") (make-instance 'module :name "wand-image.lisp") (make-instance 'module :name "wand-texture.lisp") (make-instance 'module :name "wand-pixels.lisp")) :projects (list (make-instance 'project-module :name "..\\cl-opengl\\cl-opengl")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :cl-magick :main-form nil :compilation-unit t :verbose nil :runtime-modules nil :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") :include-flags '(:local-name-info) :build-flags '(:allow-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil :default-command-line-arguments "+cx +t \"Initializing\"" :additional-build-lisp-image-arguments '(:read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard :on-initialization 'cl-magick::cl-magick-test :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cello/cvsroot/cello/cl-magick/drawing-wand.lisp 2006/05/17 16:14:29 NONE +++ /project/cello/cvsroot/cello/cl-magick/drawing-wand.lisp 2006/05/17 16:14:29 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-magick; -*- ;;; ;;; Copyright ? 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (in-package :cl-magick) ;;;/* ;;; ImageMagick Drawing Wand API. ;;;*/ ;;;#ifndef _MAGICK_DRAWING_WAND_H ;;;#define _MAGICK_DRAWING_WAND_H ;;; ;;;#if defined(__cplusplus) || defined(c_plusplus) ;;;extern "C" { ;;;#endif ;;; ;;;#include "wand/pixel_wand.h" ;;; ;;;typedef struct _DrawingWand ;;; *DrawContext ;;; DrawingWand; ;;; ;;;extern WandExport char ;;; *DrawGetClipPath( :void *DrawingWand) ;;; *DrawGetFont( :void *DrawingWand) ;;; *DrawGetFontFamily( :void *DrawingWand) ;;; *DrawGetTextEncoding( :void *DrawingWand); ;;; ;;;extern WandExport ClipPathUnits ;;; DrawGetClipUnits( :void *DrawingWand); ;;; ;;;extern WandExport DecorationType ;;; DrawGetTextDecoration( :void *DrawingWand); ;;; ;;;extern WandExport double ;;; DrawGetFillOpacity( :void *DrawingWand) ;;; DrawGetFontSize( :void *DrawingWand) ;;; *DrawGetStrokeDashArray( :void *DrawingWandunsigned long *) ;;; DrawGetStrokeDashOffset( :void *DrawingWand) ;;; DrawGetStrokeOpacity( :void *DrawingWand) ;;; DrawGetStrokeWidth( :void *DrawingWand); ;;; ;;;extern WandExport DrawInfo ;;; *DrawPeekGraphicContext( :void *DrawingWand); ;;; (defun-ffx (* :void) "imagick" "NewDrawingWand" ()) ;;;extern WandExport DrawingWand ;;; *DrawAllocateWand( DrawInfo *Image *) ;;; *NewDrawingWand(void); ;;; ;;;extern WandExport FillRule ;;; DrawGetClipRule( :void *DrawingWand) ;;; DrawGetFillRule( :void *DrawingWand); ;;; ;;;extern WandExport GravityType ;;; DrawGetGravity( :void *DrawingWand); ;;; ;;;extern WandExport LineCap ;;; DrawGetStrokeLineCap( :void *DrawingWand); ;;; ;;;extern WandExport LineJoin ;;; DrawGetStrokeLineJoin( :void *DrawingWand); ;;; ;;;extern WandExport StretchType ;;; DrawGetFontStretch( :void *DrawingWand); ;;; ;;;extern WandExport StyleType ;;; DrawGetFontStyle( :void *DrawingWand); ;;; ;;;extern WandExport :unsigned-int ;;; DrawGetStrokeAntialias( :void *DrawingWand) ;;; DrawGetTextAntialias( :void *DrawingWand) ;;; DrawRender( :void *DrawingWand); ;;; ;;;extern WandExport :unsigned-long ;;; DrawGetFontWeight( :void *DrawingWand) ;;; DrawGetStrokeMiterLimit( :void *DrawingWand); ;;; (ffx::defun-ffx-multi :void "imagick" ;;; DrawAffine(:void *DrawingWand AffineMatrix *) ;;; DrawAnnotation(:void *DrawingWand double double :unsigned-char *) ;;; DrawArc(:void *DrawingWand double double double double ;;; double double) ;;; DrawBezier(:void *DrawingWand :unsigned-long PointInfo *) ;;; DrawCircle(:void *DrawingWand double double double double) ;;; DrawColor(:void *DrawingWand double double PaintMethod) ;;; DrawComment(:void *DrawingWand char *) ;;; DestroyDrawingWand(:void *DrawingWand) "DrawEllipse" (:void *drawingwand :double ox :double oy :double rx :double ry :double start-angle :double end-angle) ;;; DrawComposite(:void *DrawingWand CompositeOperator double double ;;; double double Image *) ;;; DrawGetFillColor( :void *DrawingWandPixelWand *) ;;; DrawGetStrokeColor( :void *DrawingWandPixelWand *) ;;; DrawGetTextUnderColor( :void *DrawingWandPixelWand *) ;;; DrawLine(:void *DrawingWand double double double double) ;;; DrawMatte(:void *DrawingWand double double PaintMethod) ;;; DrawPathClose(:void *DrawingWand) ;;; DrawPathCurveToAbsolute(:void *DrawingWand double double double ;;; double double double) ;;; DrawPathCurveToRelative(:void *DrawingWand double double double ;;; double double double) ;;; DrawPathCurveToQuadraticBezierAbsolute(:void *DrawingWand double ;;; double double double) ;;; DrawPathCurveToQuadraticBezierRelative(:void *DrawingWand double ;;; double double double) ;;; DrawPathCurveToQuadraticBezierSmoothAbsolute(:void *DrawingWand double ;;; double) ;;; DrawPathCurveToQuadraticBezierSmoothRelative(:void *DrawingWand double ;;; double) ;;; DrawPathCurveToSmoothAbsolute(:void *DrawingWand double double ;;; double double) ;;; DrawPathCurveToSmoothRelative(:void *DrawingWand double double ;;; double double) ;;; DrawPathEllipticArcAbsolute(:void *DrawingWand double double ;;; double:unsigned-int:unsigned-int double double) ;;; DrawPathEllipticArcRelative(:void *DrawingWand double double ;;; double:unsigned-int:unsigned-int double double) ;;; DrawPathFinish(:void *DrawingWand) ;;; DrawPathLineToAbsolute(:void *DrawingWand double double) ;;; DrawPathLineToRelative(:void *DrawingWand double double) ;;; DrawPathLineToHorizontalAbsolute(:void *DrawingWand double) ;;; DrawPathLineToHorizontalRelative(:void *DrawingWand double) ;;; DrawPathLineToVerticalAbsolute(:void *DrawingWand double) ;;; DrawPathLineToVerticalRelative(:void *DrawingWand double) ;;; DrawPathMoveToAbsolute(:void *DrawingWand double double) ;;; DrawPathMoveToRelative(:void *DrawingWand double double) ;;; DrawPathStart(:void *DrawingWand) ;;; DrawPoint(:void *DrawingWand double double) ;;; DrawPolygon(:void *DrawingWand :unsigned-long PointInfo *) ;;; DrawPolyline(:void *DrawingWand :unsigned-long PointInfo *) ;;; DrawPopClipPath(:void *DrawingWand) ;;; DrawPopDefs(:void *DrawingWand) ;;; DrawPopGraphicContext(:void *DrawingWand) ;;; DrawPopPattern(:void *DrawingWand) ;;; DrawPushClipPath(:void *DrawingWand char *) ;;; DrawPushDefs(:void *DrawingWand) ;;; DrawPushGraphicContext(:void *DrawingWand) ;;; DrawPushPattern(:void *DrawingWand char * double double ;;; double double) ;;; DrawRectangle(:void *DrawingWand double double double ;;; double) ;;; DrawRotate(:void *DrawingWand double) ;;; DrawRoundRectangle(:void *DrawingWanddoubledoubledoubledoubledoubledouble) ;;; DrawScale(:void *DrawingWand double double) ;;; DrawSetClipPath(:void *DrawingWand char *) ;;; DrawSetClipRule(:void *DrawingWand FillRule) ;;; DrawSetClipUnits(:void *DrawingWand ClipPathUnits) ;;; DrawSetFillColor(:void *DrawingWand PixelWand *) ;;; DrawSetFillOpacity(:void *DrawingWand double) ;;; DrawSetFillRule(:void *DrawingWand FillRule) ;;; DrawSetFillPatternURL(:void *DrawingWand char *) ;;; DrawSetFont(:void *DrawingWand char *) ;;; DrawSetFontFamily(:void *DrawingWand char *) ;;; DrawSetFontSize(:void *DrawingWand double) ;;; DrawSetFontStretch(:void *DrawingWand StretchType) ;;; DrawSetFontStyle(:void *DrawingWand StyleType) ;;; DrawSetFontWeight(:void *DrawingWand :unsigned-long) ;;; DrawSetGravity(:void *DrawingWand GravityType) ;;; DrawSkewX(:void *DrawingWand double) ;;; DrawSkewY(:void *DrawingWand double) ;;; DrawSetStrokeAntialias(:void *DrawingWand :unsigned-int) ;;; DrawSetStrokeColor(:void *DrawingWand PixelWand *) ;;; DrawSetStrokeDashArray(:void *DrawingWand :unsigned-long double *) [21 lines skipped] --- /project/cello/cvsroot/cello/cl-magick/magick-wand.lisp 2006/05/17 16:14:29 NONE +++ /project/cello/cvsroot/cello/cl-magick/magick-wand.lisp 2006/05/17 16:14:29 1.1 [357 lines skipped] --- /project/cello/cvsroot/cello/cl-magick/mgk-utils.lisp 2006/05/17 16:14:29 NONE +++ /project/cello/cvsroot/cello/cl-magick/mgk-utils.lisp 2006/05/17 16:14:29 1.1 [457 lines skipped] --- /project/cello/cvsroot/cello/cl-magick/pixel-wand.lisp 2006/05/17 16:14:29 NONE +++ /project/cello/cvsroot/cello/cl-magick/pixel-wand.lisp 2006/05/17 16:14:29 1.1 [555 lines skipped] --- /project/cello/cvsroot/cello/cl-magick/wand-image.lisp 2006/05/17 16:14:29 NONE +++ /project/cello/cvsroot/cello/cl-magick/wand-image.lisp 2006/05/17 16:14:29 1.1 [665 lines skipped] --- /project/cello/cvsroot/cello/cl-magick/wand-pixels.lisp 2006/05/17 16:14:29 NONE +++ /project/cello/cvsroot/cello/cl-magick/wand-pixels.lisp 2006/05/17 16:14:29 1.1 [740 lines skipped] --- /project/cello/cvsroot/cello/cl-magick/wand-texture.lisp 2006/05/17 16:14:29 NONE +++ /project/cello/cvsroot/cello/cl-magick/wand-texture.lisp 2006/05/17 16:14:29 1.1 [875 lines skipped] From ktilton at common-lisp.net Wed May 17 16:14:30 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 17 May 2006 12:14:30 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-openal Message-ID: <20060517161430.5FF213300A@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-openal In directory clnet:/tmp/cvs-serv22618/cl-openal Added Files: al.lisp alc.lisp alctypes.lisp altypes.lisp alu.lisp alut.lisp cl-openal-config.lisp cl-openal-demo.lisp cl-openal-init.lisp cl-openal.asd cl-openal.lisp cl-openal.lpr cl-opengl-config.lisp wav-handling.lisp Log Message: CVS re-organization bringing auxiliary packages under one Cello module --- /project/cello/cvsroot/cello/cl-openal/al.lisp 2006/05/17 16:14:30 NONE +++ /project/cello/cvsroot/cello/cl-openal/al.lisp 2006/05/17 16:14:30 1.1 (in-package :cl-openal) #|* * OpenAL cross platform audio library * Copyright (C) 1999-2000 by authors. * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Library General Public * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Library General Public License for more details. * * You should have received a copy of the GNU Library General Public * License along with this library; if not, write to the * Free Software Foundation, Inc., 59 Temple Place - Suite 330, * Boston, MA 02111-1307, USA. * Or go to http://www.gnu.org/copyleft/lgpl.html |# #|* * OpenAL Maintenance Functions * Initialization and exiting. * State Management and Query. * Error Handling. * Extension Support. |# #|* State management. |# (defun-ffx al-void "openal" "alEnable" ( al-enum capability )) (defun-ffx al-void "openal" "alDisable" ( al-enum capability )) (defun-ffx al-boolean "openal" "alIsEnabled" ( al-enum capability )) #|* Application preferences for driver performance choices. |# (defun-ffx al-void "openal" "alHint" ( al-enum target al-enum mode )) #|* State retrieval. |# (defun-ffx al-boolean "openal" "alGetBoolean" ( al-enum param )) (defun-ffx al-int "openal" "alGetInteger" ( al-enum param )) (defun-ffx al-float "openal" "alGetFloat" ( al-enum param )) (defun-ffx al-double "openal" "alGetDouble" ( al-enum param )) (defun-ffx al-void "openal" "alGetBooleanv" ( al-enum param :void *data )) (defun-ffx al-void "openal" "alGetIntegerv" ( al-enum param :void *data )) (defun-ffx al-void "openal" "alGetFloatv" ( al-enum param :void *data )) (defun-ffx al-void "openal" "alGetDoublev" ( al-enum param :void *data )) (defun-ffx :pointer "openal" "alGetString" ( al-enum param )) #|* * Error support. * Obtain the most recent error generated in the AL state machine. |# (defun-ffx al-enum "openal" "alGetError" ( )) #|* * Extension support. * Obtain the address of a function (usually an extension) * with the name fname. All addresses are context-independent. |# (defun-ffx al-boolean "openal" "alIsExtensionPresent" ( :void *fname )) #|* * Extension support. * Obtain the address of a function (usually an extension) * with the name fname. All addresses are context-independent. |# (defun-ffx :pointer "openal" "alGetProcAddress" ( :void *fname )) #|* * Extension support. * Obtain the integer value of an enumeration (usually an extension) with the name ename. |# (defun-ffx al-enum "openal" "alGetEnumValue" ( :void *ename )) #|* * LISTENER * Listener is the sample position for a given context. * The multi-channel (usually stereo) output stream generated * by the mixer is parametrized by this Listener object: * its position and velocity relative to Sources, within * occluder and reflector geometry. |# #|* * * Listener Environment: default 0. |# (defun-ffx al-void "openal" "alListeneri" ( al-enum param al-int value )) #|* * * Listener Gain: default 1.0f. |# (defun-ffx al-void "openal" "alListenerf" ( al-enum param al-float value )) #|* * * Listener Position. * Listener Velocity. |# (defun-ffx al-void "openal" "alListener3f" ( al-enum param al-float v1 al-float v2 al-float v3 )) #|* * * Listener Position: ALfloat[3] * Listener Velocity: ALfloat[3] * Listener Orientation: ALfloat[6] (forward and up vector). |# (defun-ffx al-void "openal" "alListenerfv" ( al-enum param :void *values )) (defun-ffx al-void "openal" "alGetListeneri" ( al-enum param :void *value )) (defun-ffx al-void "openal" "alGetListenerf" ( al-enum param :void *value )) (defun-ffx al-void "openal" "alGetListener3f" ( al-enum param :void *v1 :void *v2 :void *v3 )) (defun-ffx al-void "openal" "alGetListenerfv" ( al-enum param :void *values )) #|* * SOURCE * Source objects are by default localized. Sources * take the PCM data provided in the specified Buffer, * apply Source-specific modifications, and then * submit them to be mixed according to spatial * arrangement etc. |# #|* Create Source objects. |# (defun-ffx al-void "openal" "alGenSources" ( al-sizei n :void *sources )) #|* Delete Source objects. |# (defun-ffx al-void "openal" "alDeleteSources" ( al-sizei n :void *sources )) #|* Verify a handle is a valid Source. |# (defun-ffx al-boolean "openal" "alIsSource" ( al-uint id )) #|* Set an integer parameter for a Source object. |# (defun-ffx al-void "openal" "alSourcei" ( al-uint source al-enum param al-int value )) (defun-ffx al-void "openal" "alSourcef" ( al-uint source al-enum param al-float value )) (defun-ffx al-void "openal" "alSource3f" ( al-uint source al-enum param al-float v1 al-float v2 al-float v3 )) (defun-ffx al-void "openal" "alSourcefv" ( al-uint source al-enum param :void *values )) #|* Get an integer parameter for a Source object. |# (defun-ffx al-void "openal" "alGetSourcei" ( al-uint source al-enum param :void *value )) (defun-ffx al-void "openal" "alGetSourcef" ( al-uint source al-enum param :void *value )) (defun-ffx al-void "openal" "alGetSource3f" ( al-uint source al-enum param :void *v1 :void *v2 :void *v3 )) (defun-ffx al-void "openal" "alGetSourcefv" ( al-uint source al-enum param :void *values )) (defun-ffx al-void "openal" "alSourcePlayv" ( al-sizei n al-uint *sources )) (defun-ffx al-void "openal" "alSourcePausev" ( al-sizei n al-uint *sources )) (defun-ffx al-void "openal" "alSourceStopv" ( al-sizei n al-uint *sources )) (defun-ffx al-void "openal" "alSourceRewindv" (al-sizei n al-uint *sources)) #|* Activate a source, start replay. |# (defun-ffx al-void "openal" "alSourcePlay" ( al-uint source )) #|* * Pause a source, * temporarily remove it from the mixer list. |# (defun-ffx al-void "openal" "alSourcePause" ( al-uint source )) #|* * Stop a source, * temporarily remove it from the mixer list, * and reset its internal state to pre-Play. * To remove a Source completely, it has to be * deleted following Stop, or before Play. |# (defun-ffx al-void "openal" "alSourceStop" ( al-uint source )) #| * * Rewinds a source, * temporarily remove it from the mixer list, * and reset its internal state to pre-Play. |# (defun-ffx al-void "openal" "alSourceRewind" ( al-uint source )) #| * * BUFFER * Buffer objects are storage space for sample data. * Buffers are referred to by Sources. There can be more than * one Source using the same Buffer data. If Buffers have * to be duplicated on a per-Source basis, the driver has to * take care of allocation, copying, and deallocation as well * as propagating buffer data changes. |# #|* Buffer object generation. |# (defun-ffx al-void "openal" "alGenBuffers" ( al-sizei n :void *buffer-uints )) (defun-ffx al-void "openal" "alDeleteBuffers" ( al-sizei n :void *buffers )) (defun-ffx al-boolean "openal" "alIsBuffer" ( al-uint buffer )) #| * * Specify the data to be filled into a buffer. * |# (defun-ffx al-void "openal" "alBufferData" ( al-uint buffer al-enum format :void *data al-sizei size al-sizei freq )) (defun-ffx al-void "openal" "alGetBufferi" ( al-uint buffer al-enum param :void *value )) (defun-ffx al-void "openal" "alGetBufferf" ( al-uint buffer al-enum param :void *value )) #| * * Queue stuff * |# (defun-ffx al-void "openal" "alSourceQueueBuffers" ( al-uint source al-sizei n :void *buffers )) (defun-ffx al-void "openal" "alSourceUnqueueBuffers" ( al-uint source al-sizei n :void *buffers )) #| * * Knobs and dials * |# (defun-ffx al-void "openal" "alDistanceModel" ( al-enum value )) (defun-ffx al-void "openal" "alDopplerFactor" ( al-float value )) (defun-ffx al-void "openal" "alDopplerVelocity" ( al-float value )) --- /project/cello/cvsroot/cello/cl-openal/alc.lisp 2006/05/17 16:14:30 NONE +++ /project/cello/cvsroot/cello/cl-openal/alc.lisp 2006/05/17 16:14:30 1.1 (in-package :cl-openal) ; typedef struct ALCdevice_struct ALCdevice; ; typedef struct ALCcontext_struct ALCcontext; ;;;(defun-ffx ALCubyte* "openal" "alcGetString" (ALCdevice *device ALCenum param)) ;;;(defun-ffx ALCvoid "openal" "alcGetIntegerv" (ALCdevice *device ALCenum param ALCsizei size ALCint *data)) ;;; (defun-ffx :pointer "openal" "alcOpenDevice" (:string device-name)) (defun-ffx :void "openal" "alcCloseDevice" (:void *device)) (defun-ffx :pointer "openal" "alcCreateContext" (:void *device alc-int *attr-list)) (defun-ffx alc-enum "openal" "alcMakeContextCurrent" (:void *context)) (defun-ffx :void "openal" "alcProcessContext" (:void *context)) (defun-ffx :pointer "openal" "alcGetCurrentContext" ()) (defun-ffx :pointer "openal" "alcGetContextsDevice" (:void *context)) (defun-ffx :void "openal" "alcSuspendContext" (:void *context)) (defun-ffx alc-enum "openal" "alcDestroyContext" (:void *context)) ;;; (defun-ffx alc-enum "openal" "alcGetError" (:void *device)) ;;; (defun-ffx alc-boolean "openal" "alcIsExtensionPresent" (:void *device alc-ubyte *ext-name)) (defun-ffx :void "openal" "alcGetProcAddress" (:void *device alc-ubyte *func-name)) (defun-ffx alc-enum "openal" "alcGetEnumValue" (:void *device alc-ubyte *enum-name)) --- /project/cello/cvsroot/cello/cl-openal/alctypes.lisp 2006/05/17 16:14:30 NONE +++ /project/cello/cvsroot/cello/cl-openal/alctypes.lisp 2006/05/17 16:14:30 1.1 (in-package :cl-openal) #| * OpenAL cross platform audio library * Copyright (C) 1999-2000 by authors. * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Library General Public * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Library General Public License for more details. * * You should have received a copy of the GNU Library General Public * License along with this library; if not, write to the * Free Software Foundation, Inc., 59 Temple Place - Suite 330, * Boston, MA 02111-1307, USA. * Or go to http://www.gnu.org/copyleft/lgpl.html |# (dft alc-boolean :unsigned-char #+allegro character #-allegro number) (dft alc-byte :char #+allegro character #-allegro number) (dft alc-ubyte :unsigned-char #+allegro character #-allegro number) (dft alc-short #-allegro-v5.0.1 :short #+allegro-v5.0.1 :int integer) (dft alc-ushort #-allegro-v5.0.1 :unsigned-int #+allegro-v5.0.1 :int integer) (dft alc-uint #-allegro-v5.0.1 :unsigned-int #+allegro-v5.0.1 :int integer) (dft alc-int :int integer) (dft alc-float #+lispworks :lisp-single-float #-lispworks :float single-float) (dft alc-double :double double-float) (dft alc-sizei #-allegro-v5.0.1 :unsigned-int #+allegro-v5.0.1 :int integer) (dft alc-void :void integer) (dft alc-enum #-allegro-v5.0.1 :unsigned-int #+allegro-v5.0.1 :int integer) (dfc alc_invalid -1) (dfc alc_false 0) (dfc alc_true 1) (dfc alc_no_error alc_false) (dfc alc_major_version #x1000) (dfc alc_minor_version #x1001) (dfc alc_attributes_size #x1002) (dfc alc_all_attributes #x1003) (dfc alc_default_device_specifier #x1004) (dfc alc_device_specifier #x1005) (dfc alc_extensions #x1006) (dfc alc_frequency #x1007) (dfc alc_refresh #x1008) (dfc alc_sync #x1009) (dfc alc_invalid_device #xa001) (dfc alc_invalid_context #xa002) (dfc alc_invalid_enum #xa003) (dfc alc_invalid_value #xa004) (dfc alc_out_of_memory #xa005) --- /project/cello/cvsroot/cello/cl-openal/altypes.lisp 2006/05/17 16:14:30 NONE +++ /project/cello/cvsroot/cello/cl-openal/altypes.lisp 2006/05/17 16:14:30 1.1 (in-package :cl-openal) #| * OpenAL cross platform audio library * Copyright (C) 1999-2000 by authors. * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Library General Public * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Library General Public License for more details. * * You should have received a copy of the GNU Library General Public * License along with this library; if not, write to the * Free Software Foundation, Inc., 59 Temple Place - Suite 330, * Boston, MA 02111-1307, USA. * Or go to http://www.gnu.org/copyleft/lgpl.html |# (dft al-enum #-allegro-v5.0.1 :unsigned-int #+allegro-v5.0.1 :int integer) (dft al-bitfield #-allegro-v5.0.1 :unsigned-int #+allegro-v5.0.1 :int integer) (dft al-int :int integer) (dft al-sizei :int integer) (dft al-uint #-allegro-v5.0.1 :unsigned-int #+allegro-v5.0.1 :int integer) (dft al-ushort #-allegro-v5.0.1 :unsigned-int #+allegro-v5.0.1 :int integer) (dft al-float #+lispworks :lisp-single-float #-lispworks :float single-float) (dft al-clampf #+lispworks :lisp-single-float #-lispworks :float single-float) (dft al-double :double double-float) (dft al-clampd :double double-float) (dft al-boolean :unsigned-char #+allegro character #-allegro number) (dft al-byte :char #+allegro character #-allegro number) ;; typedef signed char GLbyte; (dft al-void :void integer) (dft al-short #-allegro-v5.0.1 :short #+allegro-v5.0.1 :int integer) (dft al-ubyte :unsigned-char #+allegro character #-allegro number) (dft al-sizei #-allegro-v5.0.1 :unsigned-int #+allegro-v5.0.1 :int integer) (dfc al_invalid -1) (dfc al_none 0) (dfc al_false 0) (dfc al_true 1) #|* * Indicate the type of AL_SOURCE. * Sources can be spatialized |# (dfc al_source_type #x200) #|* Indicate source has absolute coordinates. |# (dfc al_source_absolute #x201) #|* Indicate Source has listener relative coordinates. |# (dfc al_source_relative #x202) #|* * Directional source, inner cone angle, in degrees. * Range: [0-360] * Default: 360 |# (dfc al_cone_inner_angle #x1001) #|* * Directional source, outer cone angle, in degrees. * Range: [0-360] * Default: 360 |# (dfc al_cone_outer_angle #x1002) #|* * Specify the pitch to be applied, either at source, [219 lines skipped] --- /project/cello/cvsroot/cello/cl-openal/alu.lisp 2006/05/17 16:14:30 NONE +++ /project/cello/cvsroot/cello/cl-openal/alu.lisp 2006/05/17 16:14:30 1.1 [258 lines skipped] --- /project/cello/cvsroot/cello/cl-openal/alut.lisp 2006/05/17 16:14:30 NONE +++ /project/cello/cvsroot/cello/cl-openal/alut.lisp 2006/05/17 16:14:30 1.1 [286 lines skipped] --- /project/cello/cvsroot/cello/cl-openal/cl-openal-config.lisp 2006/05/17 16:14:30 NONE +++ /project/cello/cvsroot/cello/cl-openal/cl-openal-config.lisp 2006/05/17 16:14:30 1.1 [327 lines skipped] --- /project/cello/cvsroot/cello/cl-openal/cl-openal-demo.lisp 2006/05/17 16:14:30 NONE +++ /project/cello/cvsroot/cello/cl-openal/cl-openal-demo.lisp 2006/05/17 16:14:30 1.1 [347 lines skipped] --- /project/cello/cvsroot/cello/cl-openal/cl-openal-init.lisp 2006/05/17 16:14:30 NONE +++ /project/cello/cvsroot/cello/cl-openal/cl-openal-init.lisp 2006/05/17 16:14:30 1.1 [438 lines skipped] --- /project/cello/cvsroot/cello/cl-openal/cl-openal.asd 2006/05/17 16:14:30 NONE +++ /project/cello/cvsroot/cello/cl-openal/cl-openal.asd 2006/05/17 16:14:30 1.1 [469 lines skipped] --- /project/cello/cvsroot/cello/cl-openal/cl-openal.lisp 2006/05/17 16:14:30 NONE +++ /project/cello/cvsroot/cello/cl-openal/cl-openal.lisp 2006/05/17 16:14:30 1.1 [531 lines skipped] --- /project/cello/cvsroot/cello/cl-openal/cl-openal.lpr 2006/05/17 16:14:30 NONE +++ /project/cello/cvsroot/cello/cl-openal/cl-openal.lpr 2006/05/17 16:14:30 1.1 [573 lines skipped] --- /project/cello/cvsroot/cello/cl-openal/cl-opengl-config.lisp 2006/05/17 16:14:30 NONE +++ /project/cello/cvsroot/cello/cl-openal/cl-opengl-config.lisp 2006/05/17 16:14:30 1.1 [616 lines skipped] --- /project/cello/cvsroot/cello/cl-openal/wav-handling.lisp 2006/05/17 16:14:30 NONE +++ /project/cello/cvsroot/cello/cl-openal/wav-handling.lisp 2006/05/17 16:14:30 1.1 [753 lines skipped] From ktilton at common-lisp.net Wed May 17 16:14:36 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 17 May 2006 12:14:36 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-opengl Message-ID: <20060517161436.D4AFD58343@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-opengl In directory clnet:/tmp/cvs-serv22618/cl-opengl Added Files: build-prep.lisp cl-opengl.asd cl-opengl.lisp cl-opengl.lpr gl-constants.lisp gl-def.lisp gl-functions.lisp glu-functions.lisp ogl-macros.lisp ogl-utils.lisp Log Message: CVS re-organization bringing auxiliary packages under one Cello module --- /project/cello/cvsroot/cello/cl-opengl/build-prep.lisp 2006/05/17 16:14:36 NONE +++ /project/cello/cvsroot/cello/cl-opengl/build-prep.lisp 2006/05/17 16:14:36 1.1 #-asdf (load "/0devtools/asdf.lisp") ;;;(push (make-pathname :directory '(:absolute "0devtools" "parse-number")) ;;; asdf:*central-registry*) ;;; ;;;(asdf:operate 'asdf:load-op 'parse-number) (progn #+lispworks (setf hcl::*handle-existing-defpackage* (list :add)) (push (make-pathname :directory '(:absolute "0devtools" "cffi")) asdf:*central-registry*) (push (make-pathname :directory '(:absolute "0devtools" "verrazano-support")) asdf:*central-registry*) (asdf:operate 'asdf:load-op 'verrazano-support :force t))--- /project/cello/cvsroot/cello/cl-opengl/cl-opengl.asd 2006/05/17 16:14:36 NONE +++ /project/cello/cvsroot/cello/cl-opengl/cl-opengl.asd 2006/05/17 16:14:36 1.1 ;;;; -*- 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))) (in-package :asdf) #-(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" :author "Kenny Tilton " :version "1.0.0" :maintainer "Kenny Tilton " :licence "MIT" :description "Partial OpenGL Bindings" :long-description "Bindings to most of OpenGL, more on demand" :perform (load-op :after (op cl-opengl) (pushnew :cl-opengl cl:*features*)) :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-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 ("ogl-macros")) (:file "nehe-14" :depends-on ("ogl-macros")))) --- /project/cello/cvsroot/cello/cl-opengl/cl-opengl.lisp 2006/05/17 16:14:36 NONE +++ /project/cello/cvsroot/cello/cl-opengl/cl-opengl.lisp 2006/05/17 16:14:36 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-opengl; -*- ;; ;;; ;;; Copyright ? 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (pushnew :cl-opengl *features*) (defpackage #:cl-opengl (:nicknames #:ogl) (:use #:common-lisp #:cffi #:ffx) (:export #:*ogl-listing-p* #:with-matrix #:with-matrix-mode #:with-attrib #:with-client-attrib #:with-gl-begun #:gl-pushm #:gl-popm #:cl-opengl-init #:closed-stream-p #:*selecting* #:cl-opengl-reset #:ogl-texture #:ncalc-normalf #:ncalc-normalfv #:ogl-get-int #:ogl-get-boolean #:v3f #:make-v3f #:v3f-x #:v3f-y #:v3f-z #:with-gl-param #:xlin #:xlout #:ups #:ups-most #:ups-more #:downs #:downs-most #:downs-more #:farther #:nearer #:ogl-texture-delete #:ogl-texture-gen #:ogl-tex-gen-setup #:ogl-bounds #:ogl-scissor-box #:ogl-raster-pos-get #:ogl-pen-move #:with-bitmap-shifted #:texture-name #:eltgli #:ogl-tex-activate #:gl-name #:mgwclose #:freeg)) (in-package :cl-opengl) (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 (gl-boolean-test (glislist lx)) do (if start (if end (if (eql lx (1+ end)) (setf end lx) (print `(gl ,start to ,end))) (if (eql lx (1+ start)) (setf end lx) (print `(gl ,start)))) (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)--- /project/cello/cvsroot/cello/cl-opengl/cl-opengl.lpr 2006/05/17 16:14:36 NONE +++ /project/cello/cvsroot/cello/cl-opengl/cl-opengl.lpr 2006/05/17 16:14:36 1.1 ;; -*- lisp-version: "8.0 [Windows] (May 11, 2006 6:29)"; cg: "1.81"; -*- (in-package :cg-user) (defpackage :CL-OPENGL) (define-project :name :cl-opengl :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 "ogl-macros.lisp") (make-instance 'module :name "ogl-utils.lisp")) :projects (list (make-instance 'project-module :name "..\\cells\\utils-kt\\utils-kt") (make-instance 'project-module :name "..\\hello-cffi\\hello-cffi")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :cl-opengl :main-form nil :compilation-unit t :verbose nil :runtime-modules nil :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") :include-flags '(:compiler :top-level :local-name-info) :build-flags '(:allow-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil :default-command-line-arguments "+cx +t \"Initializing\"" :additional-build-lisp-image-arguments '(:read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard :on-initialization 'cl-opengl::lesson-14 :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cello/cvsroot/cello/cl-opengl/gl-constants.lisp 2006/05/17 16:14:36 NONE +++ /project/cello/cvsroot/cello/cl-opengl/gl-constants.lisp 2006/05/17 16:14:36 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-opengl; -*- ;;; ;;; Copyright ? 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (in-package #:cl-opengl) #| blendingfactordest |# (dfc gl_zero 0) (dfc gl_one 1) (dfc gl_src_color #x0300) (dfc gl_one_minus_src_color #x0301) (dfc gl_src_alpha #x0302) (dfc gl_one_minus_src_alpha #x0303) (dfc gl_dst_alpha #x0304) (dfc gl_one_minus_dst_alpha #x0305) #| pixelcopytype |# (dfc gl_color #x1800) (dfc gl_depth #x1801) (dfc gl_stencil #x1802) #| pixelformat |# (dfc gl_color_index #x1900) (dfc gl_stencil_index #x1901) (dfc gl_depth_component #x1902) (dfc gl_red #x1903) (dfc gl_green #x1904) (dfc gl_blue #x1905) (dfc gl_alpha #x1906) (dfc gl_rgb #x1907) (dfc gl_rgba #x1908) (dfc gl_luminance #x1909) (dfc gl_luminance_alpha #x190a) #| polygons |# (dfc gl_point #x1b00) (dfc gl_line #x1b01) (dfc gl_fill #x1b02) (dfc gl_cw #x0900) (dfc gl_ccw #x0901) (dfc gl_front #x0404) (dfc gl_back #x0405) (dfc gl_polygon_offset_factor #x8038) (dfc gl_polygon_offset_units #x2a00) (dfc gl_polygon_offset_point #x2a01) (dfc gl_polygon_offset_line #x2a02) (dfc gl_polygon_offset_fill #x8037) #| lighting |# (dfc gl_light0 #x4000) (dfc gl_light1 #x4001) (dfc gl_light2 #x4002) (dfc gl_light3 #x4003) (dfc gl_light4 #x4004) (dfc gl_light5 #x4005) (dfc gl_light6 #x4006) (dfc gl_light7 #x4007) (dfc gl_spot_exponent #x1205) (dfc gl_spot_cutoff #x1206) (dfc gl_constant_attenuation #x1207) (dfc gl_linear_attenuation #x1208) (dfc gl_quadratic_attenuation #x1209) (dfc gl_ambient #x1200) (dfc gl_diffuse #x1201) (dfc gl_specular #x1202) (dfc gl_shininess #x1601) (dfc gl_emission #x1600) (dfc gl_position #x1203) (dfc gl_spot_direction #x1204) (dfc gl_ambient_and_diffuse #x1602) (dfc gl_color_indexes #x1603) (dfc gl_front_and_back #x0408) (dfc gl_flat #x1d00) (dfc gl_smooth #x1d01) #| user clipping planes |# (dfc gl_clip_plane0 #x3000) (dfc gl_clip_plane1 #x3001) (dfc gl_clip_plane2 #x3002) (dfc gl_clip_plane3 #x3003) (dfc gl_clip_plane4 #x3004) (dfc gl_clip_plane5 #x3005) #| boolean values |# (dfc gl_false #x0) (dfc gl_true #x1) #| data types |# (dfc gl_byte #x1400) (dfc gl_unsigned_byte #x1401) (dfc gl_short #x1402) (dfc gl_unsigned_short #x1403) (dfc gl_int #x1404) (dfc gl_unsigned_int #x1405) (dfc gl_float #x1406) (dfc gl_double #x140a) (dfc gl_2_bytes #x1407) (dfc gl_3_bytes #x1408) (dfc gl_4_bytes #x1409) #| primitives |# (dfc gl_points #x0000) (dfc gl_lines #x0001) (dfc gl_line_loop #x0002) (dfc gl_line_strip #x0003) (dfc gl_triangles #x0004) (dfc gl_triangle_strip #x0005) (dfc gl_triangle_fan #x0006) (dfc gl_quads #x0007) (dfc gl_quad_strip #x0008) (dfc gl_polygon #x0009) #| vertex arrays |# (dfc gl_vertex_array #x8074) (dfc gl_normal_array #x8075) (dfc gl_color_array #x8076) (dfc gl_index_array #x8077) (dfc gl_texture_coord_array #x8078) (dfc gl_edge_flag_array #x8079) (dfc gl_vertex_array_size #x807a) (dfc gl_vertex_array_type #x807b) (dfc gl_vertex_array_stride #x807c) (dfc gl_normal_array_type #x807e) (dfc gl_normal_array_stride #x807f) (dfc gl_color_array_size #x8081) (dfc gl_color_array_type #x8082) (dfc gl_color_array_stride #x8083) (dfc gl_index_array_type #x8085) (dfc gl_index_array_stride #x8086) (dfc gl_texture_coord_array_size #x8088) (dfc gl_texture_coord_array_type #x8089) (dfc gl_texture_coord_array_stride #x808a) (dfc gl_edge_flag_array_stride #x808c) (dfc gl_vertex_array_pointer #x808e) (dfc gl_normal_array_pointer #x808f) [346 lines skipped] --- /project/cello/cvsroot/cello/cl-opengl/gl-def.lisp 2006/05/17 16:14:36 NONE +++ /project/cello/cvsroot/cello/cl-opengl/gl-def.lisp 2006/05/17 16:14:36 1.1 [408 lines skipped] --- /project/cello/cvsroot/cello/cl-opengl/gl-functions.lisp 2006/05/17 16:14:36 NONE +++ /project/cello/cvsroot/cello/cl-opengl/gl-functions.lisp 2006/05/17 16:14:36 1.1 [818 lines skipped] --- /project/cello/cvsroot/cello/cl-opengl/glu-functions.lisp 2006/05/17 16:14:36 NONE +++ /project/cello/cvsroot/cello/cl-opengl/glu-functions.lisp 2006/05/17 16:14:36 1.1 [1061 lines skipped] --- /project/cello/cvsroot/cello/cl-opengl/ogl-macros.lisp 2006/05/17 16:14:36 NONE +++ /project/cello/cvsroot/cello/cl-opengl/ogl-macros.lisp 2006/05/17 16:14:36 1.1 [1199 lines skipped] --- /project/cello/cvsroot/cello/cl-opengl/ogl-utils.lisp 2006/05/17 16:14:36 NONE +++ /project/cello/cvsroot/cello/cl-opengl/ogl-utils.lisp 2006/05/17 16:14:36 1.1 [1420 lines skipped] From ktilton at common-lisp.net Wed May 17 18:51:31 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 17 May 2006 14:51:31 -0400 (EDT) Subject: [cello-cvs] CVS cello/hello-cffi Message-ID: <20060517185131.745871E007@common-lisp.net> Update of /project/cello/cvsroot/cello/hello-cffi In directory clnet:/tmp/cvs-serv10421/hello-cffi Log Message: Directory /project/cello/cvsroot/cello/hello-cffi added to the repository From ktilton at common-lisp.net Wed May 17 18:52:20 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 17 May 2006 14:52:20 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-ftgl Message-ID: <20060517185220.9403D1E007@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-ftgl In directory clnet:/tmp/cvs-serv10478/cl-ftgl Modified Files: cl-ftgl.lpr Log Message: --- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2006/05/17 16:14:29 1.1 +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2006/05/17 18:52:20 1.2 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Apr 21, 2006 10:24)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (May 11, 2006 6:29)"; cg: "1.81"; -*- (in-package :cg-user) @@ -6,8 +6,7 @@ (define-project :name :cl-ftgl :modules (list (make-instance 'module :name "cl-ftgl.lisp")) - :projects (list (make-instance 'project-module :name - "C:\\0devtools\\cl-opengl\\cl-opengl")) + :projects nil :libraries nil :distributed-files nil :internally-loaded-files nil From ktilton at common-lisp.net Wed May 17 18:52:20 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 17 May 2006 14:52:20 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-opengl Message-ID: <20060517185220.CFD3620006@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-opengl In directory clnet:/tmp/cvs-serv10478/cl-opengl Modified Files: cl-opengl.lpr Log Message: --- /project/cello/cvsroot/cello/cl-opengl/cl-opengl.lpr 2006/05/17 16:14:31 1.1 +++ /project/cello/cvsroot/cello/cl-opengl/cl-opengl.lpr 2006/05/17 18:52:20 1.2 @@ -13,8 +13,6 @@ (make-instance 'module :name "ogl-macros.lisp") (make-instance 'module :name "ogl-utils.lisp")) :projects (list (make-instance 'project-module :name - "..\\cells\\utils-kt\\utils-kt") - (make-instance 'project-module :name "..\\hello-cffi\\hello-cffi")) :libraries nil :distributed-files nil From ktilton at common-lisp.net Wed May 17 18:52:21 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 17 May 2006 14:52:21 -0400 (EDT) Subject: [cello-cvs] CVS cello/hello-cffi Message-ID: <20060517185221.D4EFE2001B@common-lisp.net> Update of /project/cello/cvsroot/cello/hello-cffi In directory clnet:/tmp/cvs-serv10478/hello-cffi Added Files: arrays.lisp callbacks.lisp definers.lisp ffi-extender.lisp hello-cffi.asd hello-cffi.lpr my-uffi-compat.lisp Log Message: --- /project/cello/cvsroot/cello/hello-cffi/arrays.lisp 2006/05/17 18:52:21 NONE +++ /project/cello/cvsroot/cello/hello-cffi/arrays.lisp 2006/05/17 18:52:21 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: hello-c; -*- ;;; ;;; Copyright ? 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (in-package :ffx) (defparameter *gl-rsrc* nil) (defparameter *fgn-mem* nil) (defun fgn-dump () (print (length *fgn-mem*)) (loop for fgn in *fgn-mem* do (print fgn) summing (fgn-amt fgn))) #+check (fgn-dump) (defun ffx-reset (&optional force) (hic-reset force)) (defun hic-reset (&optional force) (if force (progn (loop for fgn in *fgn-mem* do (print fgn) (foreign-free (fgn-ptr fgn)) finally (setf *fgn-mem* nil)) (loop for fgn in *gl-rsrc* do (print fgn) (glfree (fgn-type fgn)(fgn-ptr fgn)) finally (setf *gl-rsrc* nil)) (progn (when *fgn-mem* (loop for fgn in *fgn-mem* do (print fgn) finally (break "above fgn-mem not freed"))) (when *gl-rsrc* (loop for fgn in *gl-rsrc* do (print fgn) finally (break "above *gl-rsrc* not freed"))))))) (defstruct fgn ptr id type amt) (defmethod print-object ((fgn fgn) s) (format s "fgnmem ~a :amt ~a :type ~a" (fgn-id fgn)(fgn-amt fgn)(fgn-type fgn))) (defmacro fgn-alloc (type amt-form &rest keys) (let ((amt (gensym)) (ptr (gensym))) `(let* ((,amt ,amt-form) (,ptr (falloc ,type ,amt))) (call-fgn-alloc ,type ,amt ,ptr (list , at keys))))) (defun call-fgn-alloc (type amt ptr keys) ;;(print `(call-fgn-alloc ,type ,amt ,keys)) (fgn-ptr (car (push (make-fgn :id keys :type type :amt amt :ptr ptr) *fgn-mem*)))) (defun fgn-free (&rest fgn-ptrs) ;; (print `(fgn-free freeing , at fgn-ptrs)) (let ((start (copy-list fgn-ptrs))) (loop for fgn-ptr in start do (let ((fgn (find fgn-ptr *fgn-mem* :key 'fgn-ptr))) (if fgn (setf *fgn-mem* (delete fgn *fgn-mem*)) (format t "~&Freeing unknown FGN ~a" fgn-ptr)) (foreign-free fgn-ptr))))) (defun gllog (type resource amt &rest keys) (push (make-fgn :id keys :type type :amt amt :ptr resource) *gl-rsrc*)) (defun glfree (type resource) (let ((fgn (find (cons type resource) *gl-rsrc* :test 'equal :key (lambda (g) (cons (fgn-type g)(fgn-ptr g)))))) (if fgn (setf *gl-rsrc* (delete fgn *gl-rsrc*)) (format t "~&Freeing unknown GL resource ~a" (cons type resource))) #+nonono (ecase type (:texture (ogl:ogl-texture-delete resource))))) (defmacro make-ff-array (type &rest values) (let ((fv (gensym))(n (gensym))(vs (gensym))) `(let ((,fv (fgn-alloc ',type ,(length values) :make-ff-array)) (,vs (list , at values))) (dotimes (,n ,(length values) ,fv) (setf (ff-elt ,fv ,type ,n) (coerce (nth ,n ,vs) ',(if (keywordp type) (intern (symbol-name type)) (get type 'ffi-cast)))))))) (defmacro ff-list (array type count) (let ((a (gensym))(n (gensym))) `(loop with ,a = ,array for ,n below ,count collecting (ff-elt ,a ,type ,n)))) (defun make-floatv (&rest floats) (let* ((co (fgn-alloc :float (length floats) :make-floatv)) ) (apply 'ff-floatv-setf co floats))) (defmacro ff-floatv-ensure (place &rest values) `(if ,place (ff-floatv-setf ,place , at values) (setf ,place (make-floatv , at values)))) (defun ff-floatv-setf (array &rest floats) (loop for f in floats and n upfrom 0 do (setf (mem-aref array :float n) (* 1.0 f))) array) ;--------- with-ff-array-elements ------------------------------------------ (defmacro with-ff-array-elements ((fa type &rest refs) &body body) `(let ,(let ((refn -1)) (mapcar (lambda (ref) `(,ref (mem-aref ,fa ,type) ,(incf refn))) refs)) , at body)) ;-------- ff-elt --------------------------------------- (defmacro ff-elt-p (v n) `(mem-aref ,v :pointer ,n)) (defmacro ff-elt (v type n) `(mem-aref ,v ',type ,n)) (defun elti (v n) (ff-elt v :int n)) (defun (setf elti) (value v n) (setf (ff-elt v :int n) (coerce value 'integer))) (defun eltf (v n) (ff-elt v :float n)) (defun (setf eltf) (value v n) (setf (ff-elt v :float n) (coerce value 'float))) (defun elt$ (v n) (ff-elt v :string n)) (defun (setf elt$) (value v n) (setf (ff-elt v :string n) value)) (defun eltd (v n) (ff-elt v :double n)) (defun (setf eltd) (value v n) (setf (ff-elt v :double n) (coerce value 'double-float))) (defmacro fgn-pa (pa n) `(mem-aref ,pa :pointer ,n)) (eval-when (compile load eval) (export '(ffx-reset ff-elt ff-list eltf eltd elti fgn-pa with-ff-array-elements make-ff-array make-floatv ff-floatv-ensure hic-reset fgn-alloc fgn-free gllog glfree)))--- /project/cello/cvsroot/cello/hello-cffi/callbacks.lisp 2006/05/17 18:52:21 NONE +++ /project/cello/cvsroot/cello/hello-cffi/callbacks.lisp 2006/05/17 18:52:21 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: hello-c; -*- ;;; ;;; Copyright ? 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (in-package :ffx) #+precffi (defun ff-register-callable (callback-name) #+allegro (ff:register-foreign-callable callback-name) #+lispworks (let ((cb (progn ;; fli:pointer-address (fli:make-pointer :symbol-name (symbol-name callback-name) ;; leak? :functionp t)))) (print (list :ff-register-callable-returns cb)) cb)) (defun ff-register-callable (callback-name) (let ((known-callback (cffi:get-callback callback-name))) (assert known-callback) known-callback)) (defmacro ff-defun-callable (call-convention result-type name args &body body) (declare (ignorable call-convention)) `(defcallback ,name ,result-type ,args , at body)) #+precffi (defmacro ff-defun-callable (call-convention result-type name args &body body) (declare (ignorable call-convention result-type)) (let ((native-args (when args ;; without this p-f-a returns '(:void) as if for declare (process-function-args args)))) #+lispworks `(fli:define-foreign-callable (,(symbol-name name) :result-type ,result-type :calling-convention ,call-convention) (, at native-args) , at body) #+allegro `(ff:defun-foreign-callable ,name ,native-args (declare (:convention ,(ecase call-convention (:cdecl :c) (:stdcall :stdcall)))) , at body))) #+(or) (ff-defun-callable :cdecl :int square ((arg-1 :int)(data :pointer)) (list data (* arg-1 arg-1))) (eval-when (compile load eval) (export '(ff-register-callable ff-defun-callable ff-pointer-address)))--- /project/cello/cvsroot/cello/hello-cffi/definers.lisp 2006/05/17 18:52:21 NONE +++ /project/cello/cvsroot/cello/hello-cffi/definers.lisp 2006/05/17 18:52:21 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: hello-c; -*- ;;; ;;; Copyright ? 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. ;; $Header: /project/cello/cvsroot/cello/hello-cffi/definers.lisp,v 1.1 2006/05/17 18:52:20 ktilton Exp $ (in-package :ffx) (eval-when (compile load eval) (export '( defun-ffx defun-ffx-multi dffr dfc dft dfenum make-ff-pointer ff-pointer-address ))) (defun ff-pointer-address (ff-ptr) #-lispworks ff-ptr #+lispworks (fli:pointer-address ff-ptr)) ;;;(defun make-ff-pointer (n) ;;; #-lispworks ;;; n ;;; #+lispworks ;;; (fli:make-pointer :address n :pointer-type '(:pointer :void))) (defun make-ff-pointer (n) #+lispworks (fli:make-pointer :address n :pointer-type '(:pointer :void)) #+clisp (ffi:unsigned-foreign-address n) #-(or clisp lispworks) n ) (defmacro defun-ffx (rtn module$ name$ (&rest type-args) &body post-processing) (declare (ignore module$)) (let* ((lisp-fn (lisp-fn name$)) (lispfn (intern (string-upcase name$))) (var-types (let (args) (assert (evenp (length type-args)) () "uneven arg-list for ~a" name$) (dotimes (n (floor (length type-args) 2) (nreverse args)) (let ((type (elt type-args (* 2 n))) (var (elt type-args (1+ (* 2 n))))) (when (eql #\* (elt (symbol-name var) 0)) ;; no, good with *: (setf var (intern (subseq (symbol-name var) 1))) (setf type :pointer)) (push (list var type) args))))) (cast-vars (mapcar (lambda (var-type) (copy-symbol (car var-type))) var-types))) `(progn (cffi:defcfun (,name$ ,lispfn) ,(if (and (consp rtn) (eq '* (car rtn))) :pointer rtn) , at var-types) (defun ,lisp-fn ,(mapcar #'car var-types) (let ,(mapcar (lambda (cast-var var-type) `(,cast-var ,(if (listp (cadr var-type)) (car var-type) (case (cadr var-type) (:int `(coerce ,(car var-type) 'integer)) (:long `(coerce ,(car var-type) 'integer)) (:unsigned-long `(coerce ,(car var-type) 'integer)) (:unsigned-int `(coerce ,(car var-type) 'integer)) (:float `(coerce ,(car var-type) 'float)) (:double `(coerce ,(car var-type) 'double-float)) (:string (car var-type)) (:pointer (car var-type)) (otherwise (let ((ffc (get (cadr var-type) 'ffi-cast))) (assert ffc () "Don't know how to cast ~a" (cadr var-type)) `(coerce ,(car var-type) ',ffc))))))) cast-vars var-types) (prog1 (,lispfn , at cast-vars) , at post-processing))) (eval-when (compile eval load) (export '(,lispfn ,lisp-fn)))))) #+precffi (defmacro defun-ffx (rtn module$ name$ (&rest type-args) &body post-processing) (let* ((lisp-fn (lisp-fn name$)) (lispfn (intern (string-upcase name$))) (var-types (let (args) (assert (evenp (length type-args)) () "uneven arg-list for ~a" name$) (dotimes (n (floor (length type-args) 2) (nreverse args)) (let ((type (elt type-args (* 2 n))) (var (elt type-args (1+ (* 2 n))))) (when (eql #\* (elt (symbol-name var) 0)) ;; no, good with *: (setf var (intern (subseq (symbol-name var) 1))) (setf type `(* ,type))) (push (list var type) args))))) (cast-vars (mapcar (lambda (var-type) (copy-symbol (car var-type))) var-types))) `(progn (def-function (,name$ ,lispfn) ,var-types :returning ,rtn :module ,module$) (defun ,lisp-fn ,(mapcar #'car var-types) (let ,(mapcar (lambda (cast-var var-type) `(,cast-var ,(if (listp (cadr var-type)) (car var-type) (case (cadr var-type) (:int `(coerce ,(car var-type) 'integer)) (:long `(coerce ,(car var-type) 'integer)) (:unsigned-long `(coerce ,(car var-type) 'integer)) (:unsigned-int `(coerce ,(car var-type) 'integer)) (:float `(coerce ,(car var-type) 'float)) (:double `(coerce ,(car var-type) 'double-float)) [59 lines skipped] --- /project/cello/cvsroot/cello/hello-cffi/ffi-extender.lisp 2006/05/17 18:52:21 NONE +++ /project/cello/cvsroot/cello/hello-cffi/ffi-extender.lisp 2006/05/17 18:52:21 1.1 [110 lines skipped] --- /project/cello/cvsroot/cello/hello-cffi/hello-cffi.asd 2006/05/17 18:52:21 NONE +++ /project/cello/cvsroot/cello/hello-cffi/hello-cffi.asd 2006/05/17 18:52:21 1.1 [134 lines skipped] --- /project/cello/cvsroot/cello/hello-cffi/hello-cffi.lpr 2006/05/17 18:52:21 NONE +++ /project/cello/cvsroot/cello/hello-cffi/hello-cffi.lpr 2006/05/17 18:52:21 1.1 [171 lines skipped] --- /project/cello/cvsroot/cello/hello-cffi/my-uffi-compat.lisp 2006/05/17 18:52:21 NONE +++ /project/cello/cvsroot/cello/hello-cffi/my-uffi-compat.lisp 2006/05/17 18:52:21 1.1 [187 lines skipped] From ktilton at common-lisp.net Wed May 17 20:38:14 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 17 May 2006 16:38:14 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-ftgl Message-ID: <20060517203814.0BC5A3A006@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-ftgl In directory clnet:/tmp/cvs-serv25061/cl-ftgl Modified Files: cl-ftgl.lpr Log Message: Cello Rizing: cl-openal now CFFI via Hello-CFFI kluge --- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2006/05/17 18:52:20 1.2 +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2006/05/17 20:38:13 1.3 @@ -6,7 +6,8 @@ (define-project :name :cl-ftgl :modules (list (make-instance 'module :name "cl-ftgl.lisp")) - :projects nil + :projects (list (make-instance 'project-module :name + "C:\\0devtools\\cffi\\cffi")) :libraries nil :distributed-files nil :internally-loaded-files nil From ktilton at common-lisp.net Wed May 17 20:38:14 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 17 May 2006 16:38:14 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-openal Message-ID: <20060517203814.994CE42032@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-openal In directory clnet:/tmp/cvs-serv25061/cl-openal Modified Files: al.lisp alc.lisp alctypes.lisp altypes.lisp alut.lisp cl-openal-demo.lisp cl-openal-init.lisp cl-openal.lisp cl-openal.lpr wav-handling.lisp Log Message: Cello Rizing: cl-openal now CFFI via Hello-CFFI kluge --- /project/cello/cvsroot/cello/cl-openal/al.lisp 2006/05/17 16:14:29 1.1 +++ /project/cello/cvsroot/cello/cl-openal/al.lisp 2006/05/17 20:38:14 1.2 @@ -45,7 +45,7 @@ (defun-ffx al-void "openal" "alGetIntegerv" ( al-enum param :void *data )) (defun-ffx al-void "openal" "alGetFloatv" ( al-enum param :void *data )) (defun-ffx al-void "openal" "alGetDoublev" ( al-enum param :void *data )) -(defun-ffx :pointer "openal" "alGetString" ( al-enum param )) +(defun-ffx (* :void) "openal" "alGetString" ( al-enum param )) #|* * Error support. @@ -68,7 +68,7 @@ * Obtain the address of a function (usually an extension) * with the name fname. All addresses are context-independent. |# -(defun-ffx :pointer "openal" "alGetProcAddress" ( :void *fname )) +(defun-ffx (* :void) "openal" "alGetProcAddress" ( :void *fname )) #|* --- /project/cello/cvsroot/cello/cl-openal/alc.lisp 2006/05/17 16:14:29 1.1 +++ /project/cello/cvsroot/cello/cl-openal/alc.lisp 2006/05/17 20:38:14 1.2 @@ -8,14 +8,14 @@ ;;;(defun-ffx ALCvoid "openal" "alcGetIntegerv" (ALCdevice *device ALCenum param ALCsizei size ALCint *data)) ;;; -(defun-ffx :pointer "openal" "alcOpenDevice" (:string device-name)) +(defun-ffx (* :void) "openal" "alcOpenDevice" (:string device-name)) (defun-ffx :void "openal" "alcCloseDevice" (:void *device)) -(defun-ffx :pointer "openal" "alcCreateContext" (:void *device alc-int *attr-list)) +(defun-ffx (* :void) "openal" "alcCreateContext" (:void *device alc-int *attr-list)) (defun-ffx alc-enum "openal" "alcMakeContextCurrent" (:void *context)) (defun-ffx :void "openal" "alcProcessContext" (:void *context)) -(defun-ffx :pointer "openal" "alcGetCurrentContext" ()) -(defun-ffx :pointer "openal" "alcGetContextsDevice" (:void *context)) +(defun-ffx (* :void) "openal" "alcGetCurrentContext" ()) +(defun-ffx (* :void) "openal" "alcGetContextsDevice" (:void *context)) (defun-ffx :void "openal" "alcSuspendContext" (:void *context)) (defun-ffx alc-enum "openal" "alcDestroyContext" (:void *context)) ;;; --- /project/cello/cvsroot/cello/cl-openal/alctypes.lisp 2006/05/17 16:14:29 1.1 +++ /project/cello/cvsroot/cello/cl-openal/alctypes.lisp 2006/05/17 20:38:14 1.2 @@ -20,9 +20,9 @@ * Or go to http://www.gnu.org/copyleft/lgpl.html |# -(dft alc-boolean :unsigned-char #+allegro character #-allegro number) -(dft alc-byte :char #+allegro character #-allegro number) -(dft alc-ubyte :unsigned-char #+allegro character #-allegro number) +(dft alc-boolean ::unsigned-char #+allegro character #-allegro number) +(dft alc-byte :unsigned-char #+allegro character #-allegro number) +(dft alc-ubyte ::unsigned-char #+allegro character #-allegro number) (dft alc-short #-allegro-v5.0.1 :short #+allegro-v5.0.1 :int integer) (dft alc-ushort #-allegro-v5.0.1 :unsigned-int #+allegro-v5.0.1 :int integer) (dft alc-uint #-allegro-v5.0.1 :unsigned-int #+allegro-v5.0.1 :int integer) --- /project/cello/cvsroot/cello/cl-openal/altypes.lisp 2006/05/17 16:14:29 1.1 +++ /project/cello/cvsroot/cello/cl-openal/altypes.lisp 2006/05/17 20:38:14 1.2 @@ -35,12 +35,12 @@ (dft al-double :double double-float) (dft al-clampd :double double-float) -(dft al-boolean :unsigned-char #+allegro character #-allegro number) -(dft al-byte :char #+allegro character #-allegro number) ;; typedef signed char GLbyte; +(dft al-boolean ::unsigned-char #+allegro character #-allegro number) +(dft al-byte :unsigned-char #+allegro character #-allegro number) ;; typedef signed char GLbyte; (dft al-void :void integer) (dft al-short #-allegro-v5.0.1 :short #+allegro-v5.0.1 :int integer) -(dft al-ubyte :unsigned-char #+allegro character #-allegro number) +(dft al-ubyte ::unsigned-char #+allegro character #-allegro number) (dft al-sizei #-allegro-v5.0.1 :unsigned-int #+allegro-v5.0.1 :int integer) --- /project/cello/cvsroot/cello/cl-openal/alut.lisp 2006/05/17 16:14:29 1.1 +++ /project/cello/cvsroot/cello/cl-openal/alut.lisp 2006/05/17 20:38:14 1.2 @@ -3,26 +3,17 @@ (defun-ffx :void "alut" "alutInit" (:void *argc :void *argv)) (defun-ffx :void "alut" "alutExit" ()) -#+nawww -(defun-ffx :void "alut" "alutLoadWAVFile" - (:void *file :void *format :void *data - :void *size :void *freq :void *loop)) +;;;(defun-ffx :void "alut" "alutLoadWAVFile" +;;; (:void *file :void *format :void *data +;;; :void *size :void *freq :void *loop)) -(progn (defcfun ("alutloadwavfile" alut-load-wav-file) :void - (*file :pointer) (*format :pointer) (*data :pointer) (*size :pointer) (*freq :pointer) (*loop :pointer)) - - (eval-when (compile eval load) (export '( alut-load-wav-file)))) +(defun-ffx :void "alut" "alutLoadWAVFile" + (:string file :pointer *format :pointer *data + :pointer *size :pointer freq :pointer loop)) -#+nope (defun-ffx :void "alut" "alutLoadWAVMemory" (:void *memory :void *format :void *data :void *size :void *freq :void *loop)) -(progn - (defcfun ("alutloadwavmemory" alut-load-wav-memory) :void - (*memory :pointer) (*format :pointer) (*data :pointer) - (*size :pointer) (*freq :pointer) (*loop :pointer)) - (eval-when (compile eval load) (export '(alut-load-wav-memory)))) - (defun-ffx :void "alut" "alutUnloadWAV" (al-enum format :void *data al-sizei size al-sizei freq)) --- /project/cello/cvsroot/cello/cl-openal/cl-openal-demo.lisp 2006/05/17 16:14:29 1.1 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal-demo.lisp 2006/05/17 20:38:14 1.2 @@ -4,17 +4,18 @@ (defparameter g-buffers (fgn-alloc 'al-uint num_buffers)) (defun cl-openal-test () - (let ((wave-names (list "/0dev/user/sounds/jshootme.wav" ))) + (let ((w$ (list "/0dvx/user/sounds/jshootme.wav" ))) (cl-openal-init) - (apply 'wav-play-till-end - nil #+not (lambda (dur sources) - (loop for source in sources - for gain = (max 0 (- 1 (/ dur 3))) - do (al-sourcef source al_gain gain) - (al-chk "openal test GAIN set"))) - wave-names)) + (apply 'wav-play-till-end + (lambda (dur sources) + (loop for source in sources + for gain = (max 0 (- 1 (/ dur 3))) + do (al-sourcef source al_gain gain) + (al-chk "openal test GAIN set"))) + w$)) (sleep 1) (cl-openal-shutdown)) + --- /project/cello/cvsroot/cello/cl-openal/cl-openal-init.lisp 2006/05/17 16:14:29 1.1 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal-init.lisp 2006/05/17 20:38:14 1.2 @@ -24,6 +24,7 @@ (in-package :cl-openal) + (defparameter *openal-initialized-p* nil) (defun hex (dec) @@ -35,6 +36,17 @@ (when *openal-initialized-p* (return-from cl-openal-init t)) + (xoa) + + (assert (ffx:load-foreign-library (namestring *al-dynamic-lib*)) + () "Failed to load OpenAL dynamic lib ~a" *al-dynamic-lib*) + + (assert (ffx:load-foreign-library (namestring *alut-dynamic-lib*)) + () "Failed to load alut dynamic lib ~a" *alut-dynamic-lib*) + + (format t "~&Open AL loaded") + + #+shakyatbest (print `(alut init ,(alut-init 0 0))) (let ((device (loop for device-name in '("DirectSound3D" "DirectSound" "MMSYSTEM") for alc-device = (alc-open-device device-name) unless (null-pointer-p alc-device) @@ -45,8 +57,7 @@ (format t "got openal device ~a" device) - (let* ((nullargs (null-pointer)) - (context (alc-create-context device nullargs))) + (let* ((context (alc-create-context device 0))) (when (null-pointer-p context) (break "~&Failed to create Open AL context")) (format t "~&created openal context ~a" context) @@ -77,7 +88,7 @@ (let ((context (alc-get-current-context))) (unless (null-pointer-p context) (let ((device (alc-get-contexts-device context))) - (alc-make-context-current (null-pointer)) + (alc-make-context-current 0) (alc-destroy-context context) (alc-close-device device) (setf *openal-initialized-p* nil)))))) @@ -86,6 +97,6 @@ (let ((status (al-get-error))) (if (eql status al_no_error) (progn - (print (list "al-chk OK:" error$))) + #+shh (print (list "al-chk OK:" error$))) (break "~&Error< ~d > on ~a" status error$)))) --- /project/cello/cvsroot/cello/cl-openal/cl-openal.lisp 2006/05/17 16:14:29 1.1 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal.lisp 2006/05/17 20:38:14 1.2 @@ -41,22 +41,17 @@ (in-package :cl-openal) -(defparameter *audio-files* - (make-pathname - :directory '(:absolute "cell-cultures" "user" "sounds") - :type "wav")) - -(cffi:define-foreign-library OpenAL - (:darwin (:framework "OpenAL")) - (:windows (:or "C:\\Windows\\System32\\OpenAL32.dll"))) - -(cffi:define-foreign-library ALut - (:darwin (:framework "Alut")) - (:windows (:or "C:\\0dev\\user\\dynlib\\alut.dll"))) - -(eval-when (load eval) - (cffi:use-foreign-library OpenAL) - (cffi:use-foreign-library Alut)) - +#+doit +(xoa) +#+allegro +(defun xoa () + (dolist (dll (ff:list-all-foreign-libraries)) + (when (search "openal" (pathname-name dll)) + (print `(unloading foreign library ,dll)) + (ff:unload-foreign-library dll))) + (dolist (dll (ff:list-all-foreign-libraries)) + (when (search "alut" (pathname-name dll)) + (print `(unloading foreign library ,dll)) + (ff:unload-foreign-library dll)))) --- /project/cello/cvsroot/cello/cl-openal/cl-openal.lpr 2006/05/17 16:14:29 1.1 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal.lpr 2006/05/17 20:38:14 1.2 @@ -1,11 +1,12 @@ -;; -*- lisp-version: "8.0 [Windows] (May 5, 2006 15:39)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (May 11, 2006 6:29)"; cg: "1.81"; -*- (in-package :cg-user) (defpackage :CL-OPENAL) (define-project :name :cl-openal - :modules (list (make-instance 'module :name "cl-openal.lisp") + :modules (list (make-instance 'module :name "cl-openal-config.lisp") + (make-instance 'module :name "cl-openal.lisp") (make-instance 'module :name "altypes.lisp") (make-instance 'module :name "al.lisp") (make-instance 'module :name "alctypes.lisp") @@ -16,7 +17,7 @@ (make-instance 'module :name "wav-handling.lisp") (make-instance 'module :name "cl-openal-demo.lisp")) :projects (list (make-instance 'project-module :name - "..\\hello-cffi\\hello-cffi")) + "C:\\0dev\\cello\\hello-cffi\\hello-cffi")) :libraries nil :distributed-files nil :internally-loaded-files nil --- /project/cello/cvsroot/cello/cl-openal/wav-handling.lisp 2006/05/17 16:14:29 1.1 +++ /project/cello/cvsroot/cello/cl-openal/wav-handling.lisp 2006/05/17 20:38:14 1.2 @@ -80,7 +80,7 @@ (defun wav-to-buffer (wav-path) (when (cl-openal-init) - (let ((buffer (fgn-alloc 'al-uint 1)) ;; was ':pointer 1)) ;; was 'aluint + (let ((buffer (fgn-alloc 'al-uint 1)) ;; was '(* :void) 1)) ;; was 'aluint (format (fgn-alloc 'al-enum 1)) (datahandle (fgn-alloc :pointer 1)) ;; was 4 (size (fgn-alloc 'al-sizei 1)) @@ -91,25 +91,25 @@ (al-chk "wav-to-buffer al-gen-buffer") (unwind-protect - (let ((f$ (namestring wav-path))) - (alut-load-wav-file f$ format datahandle size freq loop) + (progn + (alut-load-wav-file (namestring wav-path) format datahandle size freq loop) (al-chk " wav-to-buffer alut-load-wav-File") - #+shhhh (print (list "wav loaded!" f$ + #+shhhh (print (list "wav loaded!" wav-path :format (elti format 0) :datahandle (fgn-pa datahandle 0) :size (fgn-pa size 0) :freq (fgn-pa freq 0) :loop (fgn-pa loop 0))) - (when (null-pointer-p (fgn-pa datahandle 0)) ;; 04-11-14 was elti, bad for OpenMCL - (break "null-pointer-p datahandle ~a" datahandle) + (when (null-pointer-p (fgn-pa datahandle 0)) ;; 04-11-14 was elti, bad for OpenMCL + (break "null-pointer-p datahandle ~a" datahandle) (return-from wav-to-buffer nil)) - (print (list :buffering-data (elti buffer 0) (elti format 0) (fgn-pa datahandle 0) - (elti size 0)(elti freq 0))) - (al-buffer-data (elti buffer 0) (elti format 0) (fgn-pa datahandle 0) - (elti size 0)(elti freq 0)) + (print (list :buffering-data (elti buffer 0) (elti format 0) (fgn-pa datahandle 0) + (elti size 0)(elti freq 0))) + (al-buffer-data (elti buffer 0) (elti format 0) (fgn-pa datahandle 0) + (elti size 0)(elti freq 0)) (al-chk "al-buffer-data") (alut-unload-wav (elti format 0)(fgn-pa datahandle 0) From ktilton at common-lisp.net Fri May 26 22:08:56 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 26 May 2006 18:08:56 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-ftgl Message-ID: <20060526220856.19DFB4610D@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-ftgl In directory clnet:/tmp/cvs-serv8567/cl-ftgl Modified Files: cl-ftgl.lisp cl-ftgl.lpr Log Message: Cello Rizing. cl-opengl becomes kt-opengl, hello-cffi becomes cffi-extender, end lots more to come --- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2006/05/17 16:14:29 1.1 +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2006/05/26 22:08:55 1.2 @@ -20,11 +20,11 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Header: /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp,v 1.1 2006/05/17 16:14:29 ktilton Exp $ +;;; $Header: /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp,v 1.2 2006/05/26 22:08:55 ktilton Exp $ (defpackage #:cl-ftgl (:nicknames #:ftgl) - (:use #:common-lisp #:cffi #:cl-opengl) + (:use #:common-lisp #:cffi #:kt-opengl) (:export #:ftgl #:ftgl-pixmap #:ftgl-texture --- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2006/05/17 20:38:13 1.3 +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2006/05/26 22:08:55 1.4 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (May 11, 2006 6:29)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- (in-package :cg-user) @@ -7,7 +7,7 @@ (define-project :name :cl-ftgl :modules (list (make-instance 'module :name "cl-ftgl.lisp")) :projects (list (make-instance 'project-module :name - "C:\\0devtools\\cffi\\cffi")) + "C:\\1-devtools\\cffi\\cffi")) :libraries nil :distributed-files nil :internally-loaded-files nil From ktilton at common-lisp.net Fri May 26 22:08:55 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 26 May 2006 18:08:55 -0400 (EDT) Subject: [cello-cvs] CVS cello Message-ID: <20060526220855.EA8644507C@common-lisp.net> Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv8567 Modified Files: cello.lisp cello.lpr window.lisp Log Message: Cello Rizing. cl-opengl becomes kt-opengl, hello-cffi becomes cffi-extender, end lots more to come --- /project/cello/cvsroot/cello/cello.lisp 2006/05/17 16:14:27 1.2 +++ /project/cello/cvsroot/cello/cello.lisp 2006/05/26 22:08:55 1.3 @@ -34,6 +34,7 @@ #:cl-openal #:cl-ftgl #:cl-magick - #:celtk)) + #:celtk) + (:shadowing-import-from #:celtk #:window)) (in-package :cello) --- /project/cello/cvsroot/cello/cello.lpr 2006/05/17 16:14:27 1.2 +++ /project/cello/cvsroot/cello/cello.lpr 2006/05/26 22:08:55 1.3 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (May 5, 2006 15:39)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (May 11, 2006 6:29)"; cg: "1.81"; -*- (in-package :cg-user) @@ -6,7 +6,6 @@ (define-project :name :cello :modules (list (make-instance 'module :name "cello.lisp") - (make-instance 'module :name "datetime.lisp") (make-instance 'module :name "window-macros.lisp") (make-instance 'module :name "clipping.lisp") (make-instance 'module :name "mg-geometry.lisp") @@ -48,22 +47,22 @@ (make-instance 'module :name "cello-magick.lisp") (make-instance 'module :name "cello-openal.lisp")) :projects (list (make-instance 'project-module :name - "c:\\0dev\\cells\\cells") - (make-instance 'project-module :name "..\\Celtk\\CELTK") (make-instance 'project-module :name - "c:\\0dev\\cl-opengl\\cl-opengl") + "hello-cffi\\hello-cffi") + (make-instance 'project-module :name + "cl-opengl\\cl-opengl") (make-instance 'project-module :name - "..\\cl-ftgl\\cl-ftgl") + "cl-magick\\cl-magick") (make-instance 'project-module :name - "c:\\0dev\\cl-magick\\cl-magick") + "cl-ftgl\\cl-ftgl") (make-instance 'project-module :name - "..\\cl-openal\\cl-openal")) + "cl-openal\\cl-openal")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :cello - :main-form 'cello::form3 + :main-form nil :compilation-unit t :verbose nil :runtime-modules nil --- /project/cello/cvsroot/cello/window.lisp 2006/05/17 16:14:28 1.2 +++ /project/cello/cvsroot/cello/window.lisp 2006/05/26 22:08:55 1.3 @@ -26,7 +26,7 @@ ; -(defmodel window (celtk:window focuser ix-lit-scene control ogl-shared-resource-tender) +(defmodel cello-window (celtk:window focuser ix-lit-scene control ogl-shared-resource-tender) ( (redisplayp :cell nil :initarg :redisplayp :initform nil :accessor redisplayp) (self-sizing :cell nil :initarg :self-sizing :initform nil :accessor self-sizing) From ktilton at common-lisp.net Fri May 26 22:08:56 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 26 May 2006 18:08:56 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-magick Message-ID: <20060526220856.537CA4707F@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-magick In directory clnet:/tmp/cvs-serv8567/cl-magick Modified Files: cl-magick.lisp cl-magick.lpr wand-texture.lisp Log Message: Cello Rizing. cl-opengl becomes kt-opengl, hello-cffi becomes cffi-extender, end lots more to come --- /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2006/05/17 16:14:29 1.1 +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2006/05/26 22:08:56 1.2 @@ -27,8 +27,8 @@ #-(or cormanlisp ccl) #:clos #:hello-c #:ffx - #+cl-opengl - #:cl-opengl ;; wands as opengl textures + #+kt-opengl + #:kt-opengl ;; wands as opengl textures ) (:export #:wand-manager #:wand-ensure-typed #:wands-clear #:wand-pixels #:wand-texture --- /project/cello/cvsroot/cello/cl-magick/cl-magick.lpr 2006/05/17 16:14:29 1.1 +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lpr 2006/05/26 22:08:56 1.2 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (May 5, 2006 15:39)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- (in-package :cg-user) @@ -13,8 +13,7 @@ (make-instance 'module :name "wand-image.lisp") (make-instance 'module :name "wand-texture.lisp") (make-instance 'module :name "wand-pixels.lisp")) - :projects (list (make-instance 'project-module :name - "..\\cl-opengl\\cl-opengl")) + :projects nil :libraries nil :distributed-files nil :internally-loaded-files nil --- /project/cello/cvsroot/cello/cl-magick/wand-texture.lisp 2006/05/17 16:14:29 1.1 +++ /project/cello/cvsroot/cello/cl-magick/wand-texture.lisp 2006/05/26 22:08:56 1.2 @@ -63,7 +63,7 @@ ;(print `(wand-texture-activate ,(texture-name wand))) (ogl-tex-activate (texture-name wand))) - (defparameter *textures-1* (fgn-alloc 'cl-opengl::gluint 1 :ignore)) + (defparameter *textures-1* (fgn-alloc 'kt-opengl::gluint 1 :ignore)) (defun wand-image-to-texture (self) (let ((tx (ogl-texture-gen) #+not (progn (gl-gen-textures 1 *textures-1*) (ff-elt *textures-1* gluint 0))) @@ -88,7 +88,7 @@ (gllog :texture tx (* 3 (car (image-size self)) (cdr (image-size self))) :wim2tex) (gl-tex-image2d gl_texture_2d 0 3 (car (image-size self)) (cdr (image-size self)) 0 gl_rgb gl_unsigned_byte pixels) - (cl-opengl::glec :tex-image) + (kt-opengl::glec :tex-image) ;;(print `(wand-image-to-texture loaded texture sized ,(image-size self))) (fgn-free pixels) From ktilton at common-lisp.net Fri May 26 22:08:56 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 26 May 2006 18:08:56 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-openal Message-ID: <20060526220856.BAF4C4707F@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-openal In directory clnet:/tmp/cvs-serv8567/cl-openal Modified Files: cl-openal-init.lisp cl-openal.lpr Log Message: Cello Rizing. cl-opengl becomes kt-opengl, hello-cffi becomes cffi-extender, end lots more to come --- /project/cello/cvsroot/cello/cl-openal/cl-openal-init.lisp 2006/05/17 20:38:14 1.2 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal-init.lisp 2006/05/26 22:08:56 1.3 @@ -38,10 +38,10 @@ (xoa) - (assert (ffx:load-foreign-library (namestring *al-dynamic-lib*)) + (assert (cffi-uffi-compat:load-foreign-library (namestring *al-dynamic-lib*)) () "Failed to load OpenAL dynamic lib ~a" *al-dynamic-lib*) - (assert (ffx:load-foreign-library (namestring *alut-dynamic-lib*)) + (assert (cffi-uffi-compat:load-foreign-library (namestring *alut-dynamic-lib*)) () "Failed to load alut dynamic lib ~a" *alut-dynamic-lib*) (format t "~&Open AL loaded") --- /project/cello/cvsroot/cello/cl-openal/cl-openal.lpr 2006/05/17 20:38:14 1.2 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal.lpr 2006/05/26 22:08:56 1.3 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (May 11, 2006 6:29)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- (in-package :cg-user) @@ -16,8 +16,7 @@ (make-instance 'module :name "cl-openal-init.lisp") (make-instance 'module :name "wav-handling.lisp") (make-instance 'module :name "cl-openal-demo.lisp")) - :projects (list (make-instance 'project-module :name - "C:\\0dev\\cello\\hello-cffi\\hello-cffi")) + :projects nil :libraries nil :distributed-files nil :internally-loaded-files nil From ktilton at common-lisp.net Fri May 26 22:08:57 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 26 May 2006 18:08:57 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-opengl Message-ID: <20060526220857.E95605401F@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-opengl In directory clnet:/tmp/cvs-serv8567/cl-opengl Removed Files: build-prep.lisp cl-opengl.asd cl-opengl.lisp cl-opengl.lpr gl-constants.lisp gl-def.lisp gl-functions.lisp glu-functions.lisp ogl-macros.lisp ogl-utils.lisp Log Message: Cello Rizing. cl-opengl becomes kt-opengl, hello-cffi becomes cffi-extender, end lots more to come From ktilton at common-lisp.net Fri May 26 22:08:59 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 26 May 2006 18:08:59 -0400 (EDT) Subject: [cello-cvs] CVS cello/hello-cffi Message-ID: <20060526220859.15AF3550D6@common-lisp.net> Update of /project/cello/cvsroot/cello/hello-cffi In directory clnet:/tmp/cvs-serv8567/hello-cffi Removed Files: arrays.lisp callbacks.lisp definers.lisp ffi-extender.lisp hello-cffi.asd hello-cffi.lpr my-uffi-compat.lisp Log Message: Cello Rizing. cl-opengl becomes kt-opengl, hello-cffi becomes cffi-extender, end lots more to come From ktilton at common-lisp.net Sat May 27 01:08:44 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 26 May 2006 21:08:44 -0400 (EDT) Subject: [cello-cvs] CVS cello/kt-opengl Message-ID: <20060527010844.A05EB3C005@common-lisp.net> Update of /project/cello/cvsroot/cello/kt-opengl In directory clnet:/tmp/cvs-serv30862/kt-opengl Log Message: Directory /project/cello/cvsroot/cello/kt-opengl added to the repository From ktilton at common-lisp.net Sat May 27 06:01:38 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 27 May 2006 02:01:38 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-magick Message-ID: <20060527060138.457F17020E@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-magick In directory clnet:/tmp/cvs-serv7090/cl-magick Modified Files: cl-magick.lisp Log Message: --- /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2006/05/26 22:08:56 1.2 +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2006/05/27 06:01:38 1.3 @@ -25,8 +25,8 @@ (:use #:common-lisp #-(or cormanlisp ccl) #:clos - #:hello-c - #:ffx + #:cffi + #:cffi-extender #+kt-opengl #:kt-opengl ;; wands as opengl textures ) From ktilton at common-lisp.net Sat May 27 06:01:38 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 27 May 2006 02:01:38 -0400 (EDT) Subject: [cello-cvs] CVS cello/cl-openal Message-ID: <20060527060138.909EC7020E@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-openal In directory clnet:/tmp/cvs-serv7090/cl-openal Modified Files: cl-openal-config.lisp cl-openal-demo.lisp cl-openal-init.lisp cl-openal.lisp cl-openal.lpr wav-handling.lisp Log Message: --- /project/cello/cvsroot/cello/cl-openal/cl-openal-config.lisp 2006/05/17 16:14:29 1.1 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal-config.lisp 2006/05/27 06:01:38 1.2 @@ -32,10 +32,10 @@ :type "dll")) (defparameter *alut-dynamic-lib* - (make-pathname :directory '(:absolute "0dvx" "user" "dynlib") + (make-pathname :directory '(:absolute "0dev" "user" "dynlib") :name "alut" :type "dll")) (defparameter *audio-files* (make-pathname - :directory '(:absolute "cell-cultures" "user" "sounds") + :directory '(:absolute "0dev" "user" "sounds") :type "wav")) --- /project/cello/cvsroot/cello/cl-openal/cl-openal-demo.lisp 2006/05/17 20:38:14 1.2 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal-demo.lisp 2006/05/27 06:01:38 1.3 @@ -3,8 +3,8 @@ (defconstant num_buffers 7) (defparameter g-buffers (fgn-alloc 'al-uint num_buffers)) -(defun cl-openal-test () - (let ((w$ (list "/0dvx/user/sounds/jshootme.wav" ))) +(defun cl-openal-test-many () + (let ((w$ (list "/0dev/user/sounds/jshootme.wav" ))) (cl-openal-init) (apply 'wav-play-till-end (lambda (dur sources) @@ -16,6 +16,8 @@ (sleep 1) (cl-openal-shutdown)) +(defun cl-openal-test () + (wav-play-till-end nil "/0dev/user/sounds/jshootme.wav")) --- /project/cello/cvsroot/cello/cl-openal/cl-openal-init.lisp 2006/05/26 22:08:56 1.3 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal-init.lisp 2006/05/27 06:01:38 1.4 @@ -24,13 +24,8 @@ (in-package :cl-openal) - (defparameter *openal-initialized-p* nil) -(defun hex (dec) - (let ((*print-base* 16.)(*print-radix* t)) - (princ dec))) - (defun cl-openal-init () ;;(return-from cl-openal-init nil) (when *openal-initialized-p* @@ -38,10 +33,10 @@ (xoa) - (assert (cffi-uffi-compat:load-foreign-library (namestring *al-dynamic-lib*)) + (assert (use-foreign-library OpenAL) () "Failed to load OpenAL dynamic lib ~a" *al-dynamic-lib*) - (assert (cffi-uffi-compat:load-foreign-library (namestring *alut-dynamic-lib*)) + (assert (use-foreign-library ALut) () "Failed to load alut dynamic lib ~a" *alut-dynamic-lib*) (format t "~&Open AL loaded") --- /project/cello/cvsroot/cello/cl-openal/cl-openal.lisp 2006/05/17 20:38:14 1.2 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal.lisp 2006/05/27 06:01:38 1.3 @@ -26,7 +26,7 @@ (defpackage #:cl-openal (:nicknames #:oal) - (:use #:common-lisp #:cffi #:ffx) + (:use #:common-lisp #:cffi #:cffi-extender) (:export #:xoa #:al-chk @@ -41,6 +41,19 @@ (in-package :cl-openal) +(define-foreign-library OpenAL + (:darwin (:framework "OpenAL")) + (:windows (:or "/windows/system32/openal32.dll"))) + +(define-foreign-library ALut + (:darwin (:framework "ALut")) + (:windows (:or "/windows/system32/alut.dll"))) + +(defparameter *audio-files* + (make-pathname + :directory '(:absolute "0dev" "user" "sounds") + :type "wav")) + #+doit (xoa) --- /project/cello/cvsroot/cello/cl-openal/cl-openal.lpr 2006/05/26 22:08:56 1.3 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal.lpr 2006/05/27 06:01:38 1.4 @@ -5,8 +5,7 @@ (defpackage :CL-OPENAL) (define-project :name :cl-openal - :modules (list (make-instance 'module :name "cl-openal-config.lisp") - (make-instance 'module :name "cl-openal.lisp") + :modules (list (make-instance 'module :name "cl-openal.lisp") (make-instance 'module :name "altypes.lisp") (make-instance 'module :name "al.lisp") (make-instance 'module :name "alctypes.lisp") --- /project/cello/cvsroot/cello/cl-openal/wav-handling.lisp 2006/05/17 20:38:14 1.2 +++ /project/cello/cvsroot/cello/cl-openal/wav-handling.lisp 2006/05/27 06:01:38 1.3 @@ -47,6 +47,10 @@ (al-delete-sources sct sv) (fgn-free sv))) +(defun wav-play-start (wav-path) + (assert (probe-file wav-path)) + (source-wav-play-start (car (al-source-gen 1)) wav-path)) + (defun wav-play-till-end (callback &rest wav-names) (when (cl-openal-init) (let ((sources (al-source-gen (length wav-names)))) @@ -76,7 +80,8 @@ (let ((buffer (wav-to-buffer wav-path))) (source-buffer-load source buffer) (al-source-play source) - (al-chk "al-Source-Play")))) + (al-chk "al-Source-Play") + source))) (defun wav-to-buffer (wav-path) (when (cl-openal-init) From ktilton at common-lisp.net Sat May 27 06:01:38 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 27 May 2006 02:01:38 -0400 (EDT) Subject: [cello-cvs] CVS cello Message-ID: <20060527060138.CA42C70212@common-lisp.net> Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv7090 Added Files: NeHe-06.lpr nehe-06.lisp nehe-14x.lisp Log Message: --- /project/cello/cvsroot/cello/NeHe-06.lpr 2006/05/27 06:01:38 NONE +++ /project/cello/cvsroot/cello/NeHe-06.lpr 2006/05/27 06:01:38 1.1 ;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- (in-package :cg-user) (defpackage :NEHE-06) (define-project :name :nehe-06 :modules (list (make-instance 'module :name "nehe-06.lisp") (make-instance 'module :name "nehe-14x.lisp")) :projects (list (make-instance 'project-module :name "..\\Celtk\\CELTK") (make-instance 'project-module :name "cffi-extender\\cffi-extender") (make-instance 'project-module :name "kt-opengl\\kt-opengl") (make-instance 'project-module :name "cl-magick\\cl-magick") (make-instance 'project-module :name "cl-ftgl\\cl-ftgl") (make-instance 'project-module :name "cl-openal\\cl-openal")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :nehe-06 :main-form nil :compilation-unit t :verbose nil :runtime-modules '(:cg-dde-utils :cg.base :cg.bitmap-pane :cg.bitmap-pane.clipboard :cg.bitmap-stream :cg.button :cg.caret :cg.check-box :cg.choice-list :cg.choose-printer :cg.clipboard :cg.clipboard-stack :cg.clipboard.pixmap :cg.color-dialog :cg.combo-box :cg.common-control :cg.comtab :cg.cursor-pixmap :cg.curve :cg.dialog-item :cg.directory-dialog :cg.directory-dialog-os :cg.drag-and-drop :cg.drag-and-drop-image :cg.drawable :cg.drawable.clipboard :cg.dropping-outline :cg.edit-in-place :cg.editable-text :cg.file-dialog :cg.fill-texture :cg.find-string-dialog :cg.font-dialog :cg.gesture-emulation :cg.get-pixmap :cg.get-position :cg.graphics-context :cg.grid-widget :cg.grid-widget.drag-and-drop :cg.group-box :cg.header-control :cg.hotspot :cg.html-dialog :cg.html-widget :cg.icon :cg.icon-pixmap :cg.ie :cg.item-list :cg.keyboard-shortcuts :cg.lamp :cg.lettered-menu :cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget :cg.list-view :cg.mci :cg.menu :cg.menu.tooltip :cg.message-dialog :cg.multi-line-editable-text :cg.multi-line-lisp-text :cg.multi-picture-button :cg.multi-picture-button.drag-and-drop :cg.multi-picture-button.tooltip :cg.ocx :cg.os-widget :cg.os-window :cg.outline :cg.outline.drag-and-drop :cg.outline.edit-in-place :cg.palette :cg.paren-matching :cg.picture-widget :cg.picture-widget.palette :cg.pixmap :cg.pixmap-widget :cg.pixmap.file-io :cg.pixmap.printing :cg.pixmap.rotate :cg.printing :cg.progress-indicator :cg.project-window :cg.property :cg.radio-button :cg.rich-edit :cg.rich-edit-pane :cg.rich-edit-pane.clipboard :cg.rich-edit-pane.printing :cg.sample-file-menu :cg.scaling-stream :cg.scroll-bar :cg.scroll-bar-mixin :cg.selected-object :cg.shortcut-menu :cg.static-text :cg.status-bar :cg.string-dialog :cg.tab-control :cg.template-string :cg.text-edit-pane :cg.text-edit-pane.file-io :cg.text-edit-pane.mark :cg.text-or-combo :cg.text-widget :cg.timer :cg.toggling-widget :cg.toolbar :cg.tooltip :cg.trackbar :cg.tray :cg.up-down-control :cg.utility-dialog :cg.web-browser :cg.web-browser.dde :cg.wrap-string :cg.yes-no-list :cg.yes-no-string :dde) :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") :include-flags '(:top-level :debugger) :build-flags '(:allow-runtime-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil :default-command-line-arguments "+M +t \"Console for Debugging\"" :additional-build-lisp-image-arguments '(:read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard :on-initialization 'nehe-06::nehe-06 :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cello/cvsroot/cello/nehe-06.lisp 2006/05/27 06:01:38 NONE +++ /project/cello/cvsroot/cello/nehe-06.lisp 2006/05/27 06:01:38 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; nehe-06.lisp --- Celtk/Togl version of cl-opengl Lisp version of ;;; nehe lesson 06 spinning cube with texture ;;; (defpackage :nehe-06 (:use :common-lisp :utils-kt :cells :celtk :kt-opengl :cl-magick )) (in-package :nehe-06) (defvar *startx*) (defvar *starty*) (defvar *xangle0*) (defvar *yangle0*) (defvar *xangle*) (defvar *yangle*) (defparameter *vTime* 100) (defparameter *grace* nil) (defconstant wcx 640) ;; Window Width (defconstant wcy 480) ;; Window Height (defparameter xrot 0.0f0) (defparameter yrot 0.0f0) (defparameter zrot 0.0f0) (defparameter *skin6* nil) (defun nehe-06 () ;; ACL project manager needs a zero-argument function, in project package (setf ogl::*gl-begun* nil) (test-window 'nehe-06-demo)) (defmodel nehe-06-demo (window) () (:default-initargs :title$ "Rotating nehe-06 Widget Test" :kids (c? (the-kids (mk-stack (:packing (c?pack-self)) (make-instance 'nehe06 :fm-parent *parent* :width 400 :height 400 :timer-interval 2 #+later (c? (let ((n$ (md-value (fm-other :vtime)))) (format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0))))) :double 1 ;; "yes" )))))) (defconstant +pif+ (coerce pi 'single-float)) (defmodel nehe06 (togl) ((shoot-me :cell nil :initform nil :accessor shoot-me) (frame-count :cell nil :initform 0 :accessor frame-count) (t0 :cell nil :initform 0 :accessor t0) ; (width :initarg :wdith :initform 400 :accessor width) (height :initarg :wdith :initform 400 :accessor height)) (:default-initargs :cb-destroy (lambda (self) (bwhen (s (shoot-me self)) (trc "stopping source" s) (cl-openal::al-source-stop s))))) (defmethod togl-timer-using-class ((self nehe06)) (trc nil "enter nehe-06 timer" self (togl-ptr self) (get-internal-real-time)) (Togl_PostRedisplay (togl-ptr self)) (if (shoot-me self) (unless (cl-openal::al-source-playing-p (shoot-me self)) (cl-openal::al-source-play (shoot-me self))) (setf (shoot-me self) (cl-openal::wav-play-start "/0dev/cello/user/sounds/spinning.wav")))) (defmethod togl-reshape-using-class ((self nehe06)) (let ((width (Togl_width (togl-ptr self))) (height (Togl_height (togl-ptr self)))) (trc "enter nh6 reshape" self width height) (unless (or (zerop width) (zerop height)) (gl-viewport 0 0 width height) (gl-matrix-mode gl_projection) (gl-load-identity) (glu-perspective 45 (/ width height) 0.1 100) (gl-matrix-mode gl_modelview) (gl-load-identity)))) (defparameter *jmc-font* (ftgl-make :texture 'sylfaen 48 96 18)) (defmethod togl-display-using-class ((self nehe06)) (gl-load-identity) (gl-clear (+ gl_color_buffer_bit gl_depth_buffer_bit)) (gl-line-width 1) (gl-color3f 1f0 1f0 1f0) (gl-translatef 0 0 -5) (gl-enable gl_texture_2d) ;-------------------------------------------- (progn ;; (gl-translatef 0 0 -5) (let ((f 0.2)) (gl-rotatef (incf xrot (* f 3)) 1 0 0) (gl-rotatef (incf yrot (* f 2)) 0 1 0) (gl-rotatef (incf zrot (* f 4)) 0 0 1)) (wand-texture-activate *skin6*) (flet ((v3f (x y z) (let ((scale 1)) (gl-vertex3f (* scale x)(* scale y)(* scale z))))) (with-gl-begun (gl_quads) ;; Front Face (gl-tex-coord2f 0 1)(v3f 1 -1 1) (gl-tex-coord2f 0 0)(v3f 1 1 1) (gl-tex-coord2f 1 0)(v3f -1 1 1) (gl-tex-coord2f 1 1)(v3f -1 -1 1) ;;; (gl-tex-coord2f 1 0)(v3f 1 -1 1) ;;; (gl-tex-coord2f 1 1)(v3f 1 1 1) ;;; (gl-tex-coord2f 0 1)(v3f -1 1 1) ;;; (gl-tex-coord2f 0 0)(v3f -1 -1 1) ;; Back Face (gl-tex-coord2f 1 0) (v3f -1 -1 -1) (gl-tex-coord2f 1 1) (v3f -1 1 -1) (gl-tex-coord2f 0 1) (v3f 1 1 -1) (gl-tex-coord2f 0 0) (v3f 1 -1 -1) ;;; Top Face (gl-tex-coord2f 0 1) (v3f -1 1 -1) (gl-tex-coord2f 0 0) (v3f -1 1 1) (gl-tex-coord2f 1 0) (v3f 1 1 1) (gl-tex-coord2f 1 1) (v3f 1 1 -1) ;;; Bottom Face (gl-tex-coord2f 1 1) (v3f -1 -1 -1) (gl-tex-coord2f 0 1) (v3f 1 -1 -1) (gl-tex-coord2f 0 0) (v3f 1 -1 1) (gl-tex-coord2f 1 0) (v3f -1 -1 1) ;;; Right face (gl-tex-coord2f 1 0) (v3f 1 -1 -1) (gl-tex-coord2f 1 1) (v3f 1 1 -1) (gl-tex-coord2f 0 1) (v3f 1 1 1) (gl-tex-coord2f 0 0) (v3f 1 -1 1) ;;; Left Face (gl-tex-coord2f 0 0) (v3f -1 -1 -1) (gl-tex-coord2f 1 0) (v3f -1 -1 1) (gl-tex-coord2f 1 1) (v3f -1 1 1) (gl-tex-coord2f 0 1) (v3f -1 1 -1) )) #+ifuwanttoseepixmap (wand-render *grace* 0 0 1 -1) (progn (gl-scalef 0.006 0.006 0.0) (gl-disable gl_lighting) (gl-translatef -250 -300 -100) (gl-enable gl_texture_2d) (loop repeat 4 do (ftgl-render *jmc-font* "Dr. John McCarthy") (gl-rotatef 90 0 0 1)) (gl-translatef 100 200 100) ) ) (Togl_SwapBuffers (togl-ptr self)) #+shhh (print-frame-rate self)) (defmethod togl-create-using-class ((self nehe06)) (gl-enable gl_texture_2d) (gl-shade-model gl_smooth) (gl-clear-color 0 0 0 1) (gl-clear-depth 1) (gl-enable gl_depth_test) (gl-depth-func gl_lequal) (gl-hint gl_perspective_correction_hint gl_nicest) (setf *skin6* (mgk:wand-ensure-typed 'wand-texture (test-image "jmcbw512" "jpg"))) (setf *grace* (mgk:wand-ensure-typed 'wand-pixels (test-image "turing" "gif")))) (defun print-frame-rate (window) (with-slots (frame-count t0) window (incf frame-count) (let ((time (get-internal-real-time))) (when (= t0 0) (setq t0 time)) (when (>= (- time t0) (* 5 internal-time-units-per-second)) (let* ((seconds (/ (- time t0) internal-time-units-per-second)) (fps (/ frame-count seconds))) (declare (ignorable fps)) #+shh (format *terminal-io* "~D frames in ~3,1F seconds = ~6,3F FPS~%" frame-count seconds fps)) (setq t0 time) (setq frame-count 0))))) (defun test-image (filename filetype) (make-pathname :directory '(:absolute "0dev" "user" "graphics" "shapers") :name (string filename) :type (string filetype))) --- /project/cello/cvsroot/cello/nehe-14x.lisp 2006/05/27 06:01:38 NONE +++ /project/cello/cvsroot/cello/nehe-14x.lisp 2006/05/27 06:01:38 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; nehe-14.lisp --- Celtk/Togl version of ;;; nehe lesson 14 spinning text string ;;; (defpackage :nehe-06 (:use :common-lisp :utils-kt :cells :celtk :kt-opengl :cl-ftgl)) (in-package :nehe-06) (defparameter g_rot 0.0f0) (defvar *frames*) (defvar *start*) (defvar *test-fonts*) (defun test-font (mode) (cdr (assoc mode *test-fonts*))) #+test (nehe-14) (defun nehe-14 () ;; ACL project manager needs a zero-argument function, in project package (setf ogl::*gl-begun* nil) (setq *test-fonts* (mapcar (lambda (mode) (cons mode (ftgl-make mode *gui-style-default-face* 48 96 18))) '(:texture :pixmap :bitmap :outline :polygon :extruded))) (test-window 'nehe-14-demo)) (defmodel nehe-14-demo (window) () (:default-initargs :title$ "NeHe's OpenGL Framework" :kids (c? (the-kids (mk-stack (:packing (c?pack-self)) (make-instance 'nehe14 :fm-parent *parent* :width 400 :height 400 :timer-interval 1 #+later (c? (let ((n$ (md-value (fm-other :vtime)))) (format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0))))) :double 1 ;; "yes" )))))) (defmodel nehe14 (togl) ((frame-count :cell nil :initform 0 :accessor frame-count) (t0 :cell nil :initform 0 :accessor t0) ; (width :initarg :wdith :initform 640 :accessor width) (height :initarg :wdith :initform 400 :accessor height))) (defmethod togl-timer-using-class ((self nehe14)) (trc nil "enter nehe-14 timer" self (togl-ptr self) (get-internal-real-time)) (Togl_PostRedisplay (togl-ptr self))) (defmethod togl-reshape-using-class ((self nehe14)) (let ((width (Togl_width (togl-ptr self))) (height (Togl_height (togl-ptr self)))) (trc "reshape" width height) (unless (or (zerop width) (zerop height)) (trc "reshape" width height) (gl-viewport 0 0 width height) (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)))) (defmethod togl-display-using-class ((self nehe14)) (incf *frames*) (gl-load-identity) ;; Reset The Current Modelview Matrix (gl-clear-color 0 0 0 1) (gl-clear (+ gl_color_buffer_bit gl_depth_buffer_bit)) (gl-translatef 0.0f0 0.0f0 2.0f0) ;; Move Into The Screen ;; 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-scalef 0.006 0.006 0.0) (gl-disable gl_lighting) (gl-translatef -100 -200 0) (gl-enable gl_texture_2d) (ftgl-render (test-font :texture) (format nil "texture ~d" (floor (/ *frames* (max 1 (- (now) *start*)))))) (gl-translatef 100 200 0) (gl-translatef -100 200 0) (gl-line-width 3) (ftgl-render (test-font :outline) "un-rotated outline") (gl-translatef 100 -200 0) (gl-translatef -200 100 0) (ftgl-render (test-font :polygon) "un-rotated polygon") (gl-translatef 200 -100 0) (with-matrix () (gl-polygon-mode gl_front_and_back gl_line) (gl-rotatef g_rot 1.0f0 0.5f0 0.0f0) (gl-scalef 4 4 4) (gl-translatef -70 -20 0) (ftgl-render (test-font :extruded) "NeHe") (gl-polygon-mode gl_front_and_back gl_fill) ) [103 lines skipped] From ktilton at common-lisp.net Sat May 27 06:01:39 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 27 May 2006 02:01:39 -0400 (EDT) Subject: [cello-cvs] CVS cello/kt-opengl Message-ID: <20060527060139.3451570212@common-lisp.net> Update of /project/cello/cvsroot/cello/kt-opengl In directory clnet:/tmp/cvs-serv7090/kt-opengl Added Files: cl-opengl-config-2.lisp cl-opengl-config.lisp gears.lisp gl-constants.lisp gl-def.lisp gl-functions.lisp glu-functions.lisp kt-opengl.asd kt-opengl.lisp kt-opengl.lpr move-to-gl.lisp ogl-macros.lisp ogl-utils.lisp Log Message: --- /project/cello/cvsroot/cello/kt-opengl/cl-opengl-config-2.lisp 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/cl-opengl-config-2.lisp 2006/05/27 06:01:39 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*- ;;; ;;; Copyright ? 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (in-package :kt-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")) (defun kt-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) (kt-opengl-load)) --- /project/cello/cvsroot/cello/kt-opengl/cl-opengl-config.lisp 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/cl-opengl-config.lisp 2006/05/27 06:01:39 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*- ;;; ;;; Copyright ? 2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (in-package :kt-opengl) --- /project/cello/cvsroot/cello/kt-opengl/gears.lisp 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/gears.lisp 2006/05/27 06:01:39 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; gears.lisp --- Celtk/Togl version of cl-opengl Lisp version of gears.c (GLUT Mesa demos). ;;; ;;; Simple program with rotating 3-D gear wheels. (defpackage :gears (:use :common-lisp :utils-kt :cells :celtk)) (in-package :gears) (defvar *startx*) (defvar *starty*) (defvar *xangle0*) (defvar *yangle0*) (defvar *xangle*) (defvar *yangle*) (defparameter *vTime* 100) (defun gears () ;; ACL project manager needs a zero-argument function, in project package (let ((*startx* nil) (*starty* nil) (*xangle0* nil) (*yangle0* nil) (*xangle* 0.2) (*yangle* 0.0)) (test-window 'gears-demo))) (defmodel gears-demo (window) ((gear-ct :initform (c-in 1) :accessor gear-ct :initarg :gear-ct) (scale :initform (c-in 1) :accessor scale :initarg :scale)) (:default-initargs :title$ "Rotating Gear Widget Test" :kids (c? (the-kids (mk-stack (:packing (c?pack-self "-side left -fill both")) (mk-label :text "Click and drag to rotate image") (mk-row () (mk-label :text "Spin delay (ms):") (mk-entry :id :vtime :md-value (c-in "10")) (mk-button-ex (" Quit " (tk-eval "destroy .")))) (make-instance 'gears :fm-parent *parent* :width 400 :height 400 :timer-interval (c? (let ((n$ (md-value (fm-other :vtime)))) (format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0))))) :double 1 ;; "yes" :event-handler (c? (lambda (self xe) (case (tk-event-type (xsv type xe)) (:virtualevent (trc "canvas virtual" (xsv name xe))) (:buttonpress (RotStart self (xsv x-root xe) (xsv y-root xe))) (:motionnotify (RotMove self (xsv x-root xe) (xsv y-root xe))) (:buttonrelease (setf *startx* nil))))))))))) (defun RotStart (self x y) (setf *startx* x) (setf *starty* y) (setf *xangle0* (rotx self)) (setf *yangle0* (roty self))) (defun RotMove (self x y) (when *startx* (setf *xangle* (+ *xangle0* (- x *startx*))) (setf *yangle* (+ *yangle0* (- y *starty*))) (setf (rotx self) *xangle*) (setf (roty self) *yangle*))) (defconstant +pif+ (coerce pi 'single-float)) (defmodel gears (togl) ((rotx :initform (c-in 40) :accessor rotx :initarg :rotx) (roty :initform (c-in 25) :accessor roty :initarg :roty) (rotz :initform (c-in 10) :accessor rotz :initarg :rotz) (gear1 :initarg :gear1 :accessor gear1 :initform (c_? (trc "making list!!!!! 1") (let ((dl (gl:gen-lists 1))) (gl:with-new-list (dl :compile) (gl:material :front :ambient-and-diffuse #(0.8 0.1 0.0 1.0)) (draw-gear 1.0 4.0 1.0 20 0.7)) dl))) (gear2 :initarg :gear2 :accessor gear2 :initform (c_? (let ((dl (gl:gen-lists 1))) (gl:with-new-list (dl :compile) (gl:material :front :ambient-and-diffuse #(0.0 0.8 0.2 1.0)) (draw-gear 0.5 2.0 2.0 10 0.7)) dl))) (gear3 :initarg :gear3 :accessor gear3 :initform (c_? (let ((dl (gl:gen-lists 1))) (gl:with-new-list (dl :compile) (gl:material :front :ambient-and-diffuse #(0.2 0.2 1.0 1.0)) (draw-gear 1.3 2.0 0.5 10 0.7)) dl))) (angle :initform (c-in 0.0) :accessor angle :initarg :angle) (frame-count :cell nil :initform 0 :accessor frame-count) (t0 :cell nil :initform 0 :accessor t0) ; (width :initarg :wdith :initform 400 :accessor width) (height :initarg :wdith :initform 400 :accessor height))) (defmethod togl-timer-using-class ((self gears)) (trc nil "enter gear timer" self (togl-ptr self) (get-internal-real-time)) (incf (^angle) 5.0) (Togl_PostRedisplay (togl-ptr self)) ;(loop until (zerop (ctk::Tcl_DoOneEvent 2))) ) (defmethod togl-create-using-class ((self gears)) (gl:light :light0 :position #(5.0 5.0 10.0 0.0)) (gl:enable :cull-face :lighting :light0 :depth-test) (gl:material :front :ambient-and-diffuse #(0.8 0.1 0.0 1.0)) (gl:enable :normalize) (truc self)) (defmethod togl-reshape-using-class ((self gears)) (trc "reshape") (truc self t) ) (defun truc (self &optional truly) (let ((width (Togl_width (togl-ptr self))) (height (Togl_height (togl-ptr self)))) (trc "enter gear reshape" self width (width self)) (gl:viewport 0 (- height (height self)) (width self) (height self)) (unless truly (gl:matrix-mode :projection) (gl:load-identity) (let ((h (/ height width))) (gl:frustum -1 1 (- h) h 5 60))) (progn (gl:matrix-mode :modelview) (gl:load-identity) (gl:translate 0 0 -30)))) (defmethod togl-display-using-class ((self gears) &aux (scale (scale (upper self gears-demo)))) (declare (ignorable scale)) (gl:clear-color 0 0 0 1) (gl:clear :color-buffer-bit :depth-buffer-bit) (gl:with-pushed-matrix (gl:rotate (^rotx) 1 0 0) (gl:rotate (^roty) 0 1 0) (gl:rotate (^rotz) 0 0 1) (gl:with-pushed-matrix (gl:translate -3 -2 0) (gl:rotate (^angle) 0 0 1) (gl:call-list (^gear1))) (gl:with-pushed-matrix (gl:translate 3.1 -2 0) (gl:rotate (- (* -2 (^angle)) 9) 0 0 1) (gl:call-list (^gear2))) (gl:with-pushed-matrix ; gear3 (gl:translate -3.1 4.2 0.0) (gl:rotate (- (* -2 (^angle)) 25) 0 0 1) (gl:call-list (^gear3)))) (Togl_SwapBuffers (togl-ptr self)) #+shhh (print-frame-rate self)) (defun draw-gear (inner-radius outer-radius width n-teeth tooth-depth) "Draw a gear." (declare (single-float inner-radius outer-radius width tooth-depth) (fixnum n-teeth)) (let ((r0 inner-radius) (r1 (- outer-radius (/ tooth-depth 2.0))) (r2 (+ outer-radius (/ tooth-depth 2.0))) (da (/ (* 2.0 +pif+) n-teeth 4.0))) (gl:shade-model :flat) (gl:normal 0 0 1) ;; Draw front face. (gl:with-primitives :quad-strip (dotimes (i (1+ n-teeth)) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5)) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5)) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5)) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5))))) ;; Draw front sides of teeth. (gl:with-primitives :quads (dotimes (i n-teeth) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5)) (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5)) (gl:vertex (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width 0.5)) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5))))) (gl:normal 0 0 -1) ;; Draw back face. (gl:with-primitives :quad-strip (dotimes (i (1+ n-teeth)) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5)) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5)) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width -0.5)) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5))))) ;; Draw back sides of teeth. (gl:with-primitives :quads (dotimes (i n-teeth) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* (- width) 0.5)) (gl:vertex (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* (- width) 0.5)) (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* (- width) 0.5)) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* (- width) 0.5))))) ;; Draw outward faces of teeth. (gl:with-primitives :quad-strip (dotimes (i n-teeth) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5)) (gl:vertex (* r1 (cos angle)) (* r1 (sin angle)) (* (- width) 0.5)) (let* ((u (- (* r2 (cos (+ angle da))) (* r1 (cos angle)))) (v (- (* r2 (sin (+ angle da))) (* r1 (sin angle)))) (len (sqrt (+ (* u u) (* v v))))) (setq u (/ u len)) (setq v (/ u len)) (gl:normal v (- u) 0.0) (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5)) (gl:vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* (- width) 0.5)) (gl:normal (cos angle) (sin angle) 0.0) (gl:vertex (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width 0.5)) (gl:vertex (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* (- width) 0.5)) (setq u (- (* r1 (cos (+ angle (* 3 da)))) (* r2 (cos (+ angle (* 2 da)))))) (setq v (- (* r1 (sin (+ angle (* 3 da)))) (* r2 (sin (+ angle (* 2 da)))))) (gl:normal v (- u) 0.0) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5)) (gl:vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* (- width) 0.5)) (gl:normal (cos angle) (sin angle) 0.0)))) (gl:vertex (* r1 (cos 0)) (* r1 (sin 0)) (* width 0.5)) (gl:vertex (* r1 (cos 0)) (* r1 (sin 0)) (* (- width) 0.5))) ;; Draw inside radius cylinder. (gl:shade-model :smooth) (gl:with-primitives :quad-strip (dotimes (i (1+ n-teeth)) (let ((angle (/ (* i 2.0 +pif+) n-teeth))) (gl:normal (- (cos angle)) (- (sin angle)) 0.0) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* (- width) 0.5)) (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5))))))) (defun print-frame-rate (window) (with-slots (frame-count t0) window (incf frame-count) (let ((time (get-internal-real-time))) (when (= t0 0) (setq t0 time)) (when (>= (- time t0) (* 5 internal-time-units-per-second)) (let* ((seconds (/ (- time t0) internal-time-units-per-second)) (fps (/ frame-count seconds))) (declare (ignorable fps)) #+shh (format *terminal-io* "~D frames in ~3,1F seconds = ~6,3F FPS~%" frame-count seconds fps)) (setq t0 time) (setq frame-count 0))))) --- /project/cello/cvsroot/cello/kt-opengl/gl-constants.lisp 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/gl-constants.lisp 2006/05/27 06:01:39 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: kt-opengl; -*- ;;; ;;; Copyright ? 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (in-package #:kt-opengl) #| blendingfactordest |# (dfc gl_zero 0) (dfc gl_one 1) (dfc gl_src_color #x0300) (dfc gl_one_minus_src_color #x0301) (dfc gl_src_alpha #x0302) (dfc gl_one_minus_src_alpha #x0303) (dfc gl_dst_alpha #x0304) (dfc gl_one_minus_dst_alpha #x0305) (dfc gl_dst_color #x0306) (dfc gl_one_minus_dst_color #x0307) (dfc gl_src_alpha_saturate #x0308) #| pixelcopytype |# (dfc gl_color #x1800) (dfc gl_depth #x1801) [463 lines skipped] --- /project/cello/cvsroot/cello/kt-opengl/gl-def.lisp 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/gl-def.lisp 2006/05/27 06:01:39 1.1 [525 lines skipped] --- /project/cello/cvsroot/cello/kt-opengl/gl-functions.lisp 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/gl-functions.lisp 2006/05/27 06:01:39 1.1 [906 lines skipped] --- /project/cello/cvsroot/cello/kt-opengl/glu-functions.lisp 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/glu-functions.lisp 2006/05/27 06:01:39 1.1 [1138 lines skipped] --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl.asd 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.asd 2006/05/27 06:01:39 1.1 [1163 lines skipped] --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lisp 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lisp 2006/05/27 06:01:39 1.1 [1280 lines skipped] --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lpr 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lpr 2006/05/27 06:01:39 1.1 [1320 lines skipped] --- /project/cello/cvsroot/cello/kt-opengl/move-to-gl.lisp 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/move-to-gl.lisp 2006/05/27 06:01:39 1.1 [1411 lines skipped] --- /project/cello/cvsroot/cello/kt-opengl/ogl-macros.lisp 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/ogl-macros.lisp 2006/05/27 06:01:39 1.1 [1561 lines skipped] --- /project/cello/cvsroot/cello/kt-opengl/ogl-utils.lisp 2006/05/27 06:01:39 NONE +++ /project/cello/cvsroot/cello/kt-opengl/ogl-utils.lisp 2006/05/27 06:01:39 1.1 [1809 lines skipped]