cello-cvs

Download

cello-cvs@common-lisp.net

May 2006

1 participants
32 discussions

[cello-cvs] CVS hello-c
by ktilton 16 May '06

16 May '06

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 ,@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 ,@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)) ,@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 ,@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 @@ ,@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) + ,@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 ,@cast-vars) + ,@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 <ktilton(a)nyc.rr.com>" :version "1.0.0" :maintainer "Kenny Tilton <ktilton(a)nyc.rr.com>" :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))

1 0

[cello-cvs] CVS cl-opengl
by ktilton 14 May '06

14 May '06

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 () ,@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 () ,@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) ,@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))))

1 0