- cello-cvs@common-lisp.net - mailman3.common-lisp.net

[cello-cvs] CVS hello-cffi
by ktilton 17 May '06

17 May '06

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 ,@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 ,@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 ,@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 ,@values) (setf ,place (make-floatv ,@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)) ,@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 ,@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) (,@native-args) ,@body) #+allegro `(ff:defun-foreign-callable ,name ,native-args (declare (:convention ,(ecase call-convention (:cdecl :c) (:stdcall :stdcall)))) ,@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) ,@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) (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]

1 0

[cello-cvs] CVS hello-cffi
by ktilton 17 May '06

17 May '06

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

1 0

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

15 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 13 May '06

13 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

[cello-cvs] CVS update: hello-c/definers.lisp hello-c/hello-c.lpr hello-c/primitives.lisp hello-c/strings.lisp
by ktilton＠common-lisp.net 10 Jul '05

10 Jul '05

Update of /project/cello/cvsroot/hello-c In directory common-lisp.net:/tmp/cvs-serv3125 Modified Files: definers.lisp hello-c.lpr primitives.lisp strings.lisp Log Message: No comment Date: Sun Jul 10 23:35:01 2005 Author: ktilton Index: hello-c/definers.lisp diff -u hello-c/definers.lisp:1.1 hello-c/definers.lisp:1.2 --- hello-c/definers.lisp:1.1 Tue May 24 01:51:57 2005 +++ hello-c/definers.lisp Sun Jul 10 23:35:01 2005 @@ -20,7 +20,7 @@ ;;; 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.1 2005/05/23 23:51:57 ktilton Exp $ +;; $Header: /project/cello/cvsroot/hello-c/definers.lisp,v 1.2 2005/07/10 21:35:01 ktilton Exp $ (in-package :hello-c) @@ -39,11 +39,17 @@ #-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 - n - #+lispworks - (fli:make-pointer :address n :pointer-type '(:pointer :void))) + #+allegro (ff:make-foreign-pointer :address n :type '(* void)) + #+lispworks (fli:make-pointer :address n :pointer-type '(:pointer :void)) + #-(or lispworks allegro) n + ) (defmacro defun-ffx (rtn module$ name$ (&rest type-args) &body post-processing) (let* ((lisp-fn (lisp-fn name$)) Index: hello-c/hello-c.lpr diff -u hello-c/hello-c.lpr:1.1 hello-c/hello-c.lpr:1.2 --- hello-c/hello-c.lpr:1.1 Tue May 24 01:51:57 2005 +++ hello-c/hello-c.lpr Sun Jul 10 23:35:01 2005 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "7.0 [Windows] (May 6, 2005 8:25)"; cg: "1.54.2.17"; -*- +;; -*- lisp-version: "7.0 [Windows] (Jun 10, 2005 13:34)"; cg: "1.54.2.17"; -*- (in-package :cg-user) Index: hello-c/primitives.lisp diff -u hello-c/primitives.lisp:1.1 hello-c/primitives.lisp:1.2 --- hello-c/primitives.lisp:1.1 Tue May 24 01:51:57 2005 +++ hello-c/primitives.lisp Sun Jul 10 23:35:01 2005 @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: primitives.lisp,v 1.1 2005/05/23 23:51:57 ktilton Exp $ +;;;; $Id: primitives.lisp,v 1.2 2005/07/10 21:35:01 ktilton Exp $ ;;;; ;;;; This file, part of hello-c, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -242,37 +242,37 @@ (cond #+(or allegro cormanlisp) ((and (or (eq context :routine) (eq context :return)) - (eq type :cstring)) - (setq type '((* :char) integer))) + (eq type :cstring)) + (setq type '((* :char) integer))) #+(or cmu sbcl scl) ((eq context :type) - (let ((cmu-type (gethash type *cmu-def-type-hash*))) - (if cmu-type - cmu-type - (basic-convert-from-uffi-type type)))) + (let ((cmu-type (gethash type *cmu-def-type-hash*))) + (if cmu-type + cmu-type + (basic-convert-from-uffi-type type)))) #+lispworks ((and (eq context :return) - (eq type :cstring)) - (basic-convert-from-uffi-type :cstring-returning)) + (eq type :cstring)) + (basic-convert-from-uffi-type :cstring-returning)) #+(and mcl (not openmcl)) ((and (eq type :void) (eq context :return)) nil) (t - (basic-convert-from-uffi-type type))) + (basic-convert-from-uffi-type type))) (let ((sub-type (car type))) (case sub-type - (cl:quote - (convert-from-uffi-type (cadr type) context)) - (:struct-pointer - #+mcl `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct))) - #-mcl (%convert-from-uffi-type (list '* (cadr type)) :struct) - ) - (:struct - #+mcl `(:struct ,(%convert-from-uffi-type (cadr type) :struct)) - #-mcl (%convert-from-uffi-type (cadr type) :struct) - ) - (t - (cons (%convert-from-uffi-type (first type) context) - (%convert-from-uffi-type (rest type) context))))))) + (cl:quote + (convert-from-uffi-type (cadr type) context)) + (:struct-pointer + #+mcl `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct))) + #-mcl (%convert-from-uffi-type (list '* (cadr type)) :struct) + ) + (:struct + #+mcl `(:struct ,(%convert-from-uffi-type (cadr type) :struct)) + #-mcl (%convert-from-uffi-type (cadr type) :struct) + ) + (t + (cons (%convert-from-uffi-type (first type) context) + (%convert-from-uffi-type (rest type) context))))))) #+test Index: hello-c/strings.lisp diff -u hello-c/strings.lisp:1.1 hello-c/strings.lisp:1.2 --- hello-c/strings.lisp:1.1 Tue May 24 01:51:57 2005 +++ hello-c/strings.lisp Sun Jul 10 23:35:01 2005 @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: strings.lisp,v 1.1 2005/05/23 23:51:57 ktilton Exp $ +;;;; $Id: strings.lisp,v 1.2 2005/07/10 21:35:01 ktilton Exp $ ;;;; ;;;; This file, part of hic, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -68,28 +68,31 @@ (dispose-ptr ,obj)) ) -(defmacro with-cstring ((cstring lisp-string) &body body) +(defmacro with-cstring ((cstring lisp$-form) &body body) #+(or cmu sbcl scl lispworks) - `(let ((,cstring ,lisp-string)) ,@body) + `(let ((,cstring ,lisp$-form)) ,@body) #+allegro (let ((acl-native (gensym))) - `(excl:with-native-string (,acl-native ,lisp-string) - (let ((,cstring (if ,lisp-string ,acl-native 0))) - ,@body))) + `(excl:with-native-string (,acl-native ,lisp$-form) + (let ((,cstring ,(if lisp$-form acl-native 0))) + ,@body))) #+mcl - `(if (stringp ,lisp-string) - (ccl:with-cstrs ((,cstring ,lisp-string)) - ,@body) - (let ((,cstring +null-cstring-pointer+)) - ,@body)) - ) + (let ((lisp$ (gensym))) + `(let ((,lisp$ (let ((,lisp$ ,lisp$-form)) + (typecase ,lisp$ + (null +null-cstring-pointer+) + (string ,lisp$) + (t (error "with-cstring asked to handle non-string ~a" ,lisp$)))))) + (ccl:with-cstrs ((,cstring ,lisp$)) + ,@body)))) + (defmacro with-cstrings (bindings &rest body) (if bindings `(with-cstring ,(car bindings) - (with-cstrings ,(cdr bindings) - ,@body)) - `(progn ,@body))) + (with-cstrings ,(cdr bindings) + ,@body)) + `(progn ,@body))) ;;; Foreign string functions

1 0

[cello-cvs] CVS update: cl-opengl/cl-opengl.lisp cl-opengl/gl-constants.lisp cl-opengl/gl-functions.lisp cl-opengl/glu-functions.lisp cl-opengl/nehe-14.lisp cl-opengl/ogl-macros.lisp cl-opengl/ogl-utils.lisp
by ktilton＠common-lisp.net 08 Jul '05

08 Jul '05

Update of /project/cello/cvsroot/cl-opengl In directory common-lisp.net:/tmp/cvs-serv29876 Modified Files: cl-opengl.lisp gl-constants.lisp gl-functions.lisp glu-functions.lisp nehe-14.lisp ogl-macros.lisp ogl-utils.lisp Log Message: Filling in omitted subdirectory Date: Fri Jul 8 18:26:48 2005 Author: ktilton Index: cl-opengl/cl-opengl.lisp diff -u cl-opengl/cl-opengl.lisp:1.1 cl-opengl/cl-opengl.lisp:1.2 --- cl-opengl/cl-opengl.lisp:1.1 Wed May 25 05:14:30 2005 +++ cl-opengl/cl-opengl.lisp Fri Jul 8 18:26:47 2005 @@ -31,8 +31,8 @@ #:glut-get-window #:glut-set-window #:glut-post-redisplay - #:with-matrix - #:with-attrib + #:with-matrix #:with-matrix-mode + #:with-attrib #:with-client-attrib #:with-gl-begun #:gl-pushm #:gl-popm Index: cl-opengl/gl-constants.lisp diff -u cl-opengl/gl-constants.lisp:1.1 cl-opengl/gl-constants.lisp:1.2 --- cl-opengl/gl-constants.lisp:1.1 Wed May 25 05:14:30 2005 +++ cl-opengl/gl-constants.lisp Fri Jul 8 18:26:47 2005 @@ -347,6 +347,9 @@ (dfc gl_texture_matrix #x0ba8) (dfc gl_attrib_stack_depth #x0bb0) (dfc gl_client_attrib_stack_depth #x0bb1) +(dfc gl_client_pixel_store_bit #x00000001) +(dfc gl_client_vertex_array_bit #x00000002) +(dfc gl_client_all_attrib_bits #xffffffff) (dfc gl_alpha_test #x0bc0) (dfc gl_alpha_test_func #x0bc1) (dfc gl_alpha_test_ref #x0bc2) Index: cl-opengl/gl-functions.lisp diff -u cl-opengl/gl-functions.lisp:1.1 cl-opengl/gl-functions.lisp:1.2 --- cl-opengl/gl-functions.lisp:1.1 Wed May 25 05:14:31 2005 +++ cl-opengl/gl-functions.lisp Fri Jul 8 18:26:47 2005 @@ -162,8 +162,12 @@ (defun-ffx :void "open-gl" "glTexParameterfv" (glenum target glenum pname glfloat *params)) (defun-ffx :void "open-gl" "glTexParameteri" (glenum target glenum pname glint param)) (defun-ffx :void "open-gl" "glTexParameteriv" (glenum target glenum pname glint *params)) -;;;(defun-ffx :void "open-gl" "glTexSubImage1D" (GLenum target GLint level GLint xoffset GLsizei width GLenum format GLenum type GLvoid *pixels)) -;;;(defun-ffx :void "open-gl" "glTexSubImage2D" (GLenum target GLint level GLint xoffset GLint yoffset GLsizei width GLsizei height GLenum format GLenum type GLvoid *pixels)) +(defun-ffx :void "open-gl" "glTexSubImage1D" (GLenum target GLint level GLint xoffset + GLsizei width + GLenum format GLenum type GLvoid *pixels)) +(defun-ffx :void "open-gl" "glTexSubImage2D" (GLenum target GLint level GLint xoffset + GLint yoffset GLsizei width GLsizei height + GLenum format GLenum type GLvoid *pixels)) (defun-ffx :void "open-gl" "glGenTextures" (glsizei n gluint *textures)) (defun-ffx :void "open-gl" "glBindTexture" (glenum target gluint texture)) @@ -346,14 +350,34 @@ (defun-ogl :void "open-gl" "glTranslatef" (glfloat x glfloat y glfloat z )) (defun-ogl :void "open-gl" "glBitmap" (glsizei width glsizei height - glfloat xorig glfloat yorig - glfloat xmove glfloat ymove)) - + glfloat xorig glfloat yorig + glfloat xmove glfloat ymove + char *data)) + +#+not +(DEFUN-FFX :VOID "open-gl" "glBitmap" + (GLSIZEI WIDTH GLSIZEI HEIGHT + GLFLOAT XORIG GLFLOAT YORIG + GLFLOAT XMOVE GLFLOAT YMOVE + GLbyte *DATA)) + +#+not +(DEF-FUNCTION ("glBitmap" GLBITMAP) + ((WIDTH GLSIZEI) (HEIGHT GLSIZEI) (XORIG GLFLOAT) (YORIG GLFLOAT) (XMOVE GLFLOAT) + (YMOVE GLFLOAT) (*DATA :pointer-void)) + :RETURNING :VOID :MODULE "open-gl" + :call-direct t) + +;;;(FF:DEF-FOREIGN-CALL (GLBITMAP "glBitmap") +;;; ((WIDTH GLSIZEI) (HEIGHT GLSIZEI) (XORIG GLFLOAT) (YORIG GLFLOAT) (XMOVE GLFLOAT) +;;; (YMOVE GLFLOAT) (*DATA (* :void))) +;;; :RETURNING :VOID :CALL-DIRECT T :STRINGS-CONVERT NIL) (defun-ogl :void "open-gl" "glReadPixels" ( glint x glint y glsizei width glsizei height glenum format glenum type glvoid *pixels )) (defun-ogl :void "open-gl" "glDrawPixels" (glsizei width glsizei height glenum format glenum type glvoid *pixels)) + (defun-ogl :void "open-gl" "glCopyPixels" ( glint x glint y glsizei width glsizei height glenum type )) #| stenciling |# Index: cl-opengl/glu-functions.lisp diff -u cl-opengl/glu-functions.lisp:1.2 cl-opengl/glu-functions.lisp:1.3 --- cl-opengl/glu-functions.lisp:1.2 Wed Jun 15 23:09:09 2005 +++ cl-opengl/glu-functions.lisp Fri Jul 8 18:26:47 2005 @@ -156,8 +156,9 @@ (defun-ogl (* glubyte) "gl-util" "gluErrorString" (glenum error)) ;;;(defun-ogl GLubyte *"gl-util" "gluGetString" (GLenum name)) -;;;(defun-ogl void "gl-util" "gluGetTessProperty" (GLUtesselator *tess GLenum which GLdouble *data)) -;;;(defun-ogl void "gl-util" "gluLoadSamplingMatrices" (GLUnurbs *nurb GLfloat *model GLfloat *perspective GLint *view)) +(defun-ogl :void "gl-util" "gluGetTessProperty" (:void *tess GLenum which GLdouble *data)) + +;;;(defun-ogl :void "gl-util" "gluLoadSamplingMatrices" (GLUnurbs *nurb GLfloat *model GLfloat *perspective GLint *view)) (defun-ogl :int "gl-util" "gluBuild2DMipmaps" (glenum target glint components @@ -196,11 +197,10 @@ (defun-ogl :void "gl-util" "gluNurbsProperty" (:void *nurb GLenum property GLfloat value)) (defun-ogl :void "gl-util" "gluNurbsSurface" (:void *nurb GLint sKnotCount GLfloat *sKnots GLint tKnotCount GLfloat *tKnots GLint sStride GLint tStride GLfloat *control GLint sOrder GLint tOrder GLenum type)) -;;;(defun-ogl GLUtesselator *"gl-util" "gluNewTess" ()) -;;;(defun-ogl void "gl-util" "gluNextContour" (GLUtesselator *tess GLenum type)) +(defun-ogl :void "gl-util" "gluNextContour" (:void *tess GLenum type)) (defun-ogl :void "gl-util" "gluOrtho2D" (GLdouble left GLdouble right GLdouble bottom GLdouble top)) -;;;(defun-ogl void "gl-util" "gluPartialDisk" (GLUquadric *quad GLdouble inner GLdouble outer GLint slices GLint loops GLdouble start GLdouble sweep)) +;;;(defun-ogl :void "gl-util" "gluPartialDisk" (GLUquadric *quad GLdouble inner GLdouble outer GLint slices GLint loops GLdouble start GLdouble sweep)) (defun-ogl :void "gl-util" "gluPerspective" (gldouble fovy gldouble aspect gldouble z-near gldouble z-far)) @@ -208,20 +208,24 @@ (defun-ogl glint "gl-util" "gluProject" (gldouble obj-x gldouble obj-y gldouble obj-z gldouble *model gldouble *proj glint *view gldouble *winx gldouble *winy gldouble *winz)) -;;;(defun-ogl void "gl-util" "gluPwlCurve" (GLUnurbs *nurb GLint count GLfloat *data GLint stride GLenum type)) -;;;(defun-ogl void "gl-util" "gluQuadricDrawStyle" (GLUquadric *quad GLenum draw)) -;;;(defun-ogl void "gl-util" "gluQuadricNormals" (GLUquadric *quad GLenum normal)) -;;;(defun-ogl void "gl-util" "gluQuadricOrientation" (GLUquadric *quad GLenum orientation)) -(defun-ogl :void "gl-util" "gluQuadricTexture" (:void *quad glboolean texture)) +;;;(defun-ogl :void "gl-util" "gluPwlCurve" (GLUnurbs *nurb GLint count GLfloat *data GLint stride GLenum type)) +;;;(defun-ogl :void "gl-util" "gluQuadricDrawStyle" (GLUquadric *quad GLenum draw)) +;;;(defun-ogl :void "gl-util" "gluQuadricNormals" (GLUquadric *quad GLenum normal)) +;;;(defun-ogl :void "gl-util" "gluQuadricOrientation" (GLUquadric *quad GLenum orientation)) +(defun-ogl :void "gl-util" "gluQuadricTexture" (:void *quad glint texture)) ;;;(defun-ogl GLint "gl-util" "gluScaleImage" (GLenum format GLsizei wIn GLsizei hIn GLenum typeIn void *dataIn GLsizei wOut GLsizei hOut GLenum typeOut GLvoid *dataOut)) -;;;(defun-ogl void "gl-util" "gluSphere" (GLUquadric *quad GLdouble radius GLint slices GLint stacks)) -;;;(defun-ogl void "gl-util" "gluTessBeginContour" (GLUtesselator *tess)) -;;;(defun-ogl void "gl-util" "gluTessBeginPolygon" (GLUtesselator *tess GLvoid *data)) -;;;(defun-ogl void "gl-util" "gluTessEndContour" (GLUtesselator *tess)) -;;;(defun-ogl void "gl-util" "gluTessEndPolygon" (GLUtesselator *tess)) -;;;(defun-ogl void "gl-util" "gluTessNormal" (GLUtesselator *tess GLdouble valueX GLdouble valueY GLdouble valueZ)) -;;;(defun-ogl void "gl-util" "gluTessProperty" (GLUtesselator *tess GLenum which GLdouble data)) -;;;(defun-ogl void "gl-util" "gluTessVertex" (GLUtesselator *tess GLdouble *location GLvoid *data)) +;;;(defun-ogl :void "gl-util" "gluSphere" (GLUquadric *quad GLdouble radius GLint slices GLint stacks)) + (defun-ogl glint "gl-util" "gluUnProject" (gldouble winx gldouble winy gldouble winz gldouble *model gldouble *proj glint *view gldouble *obj-x gldouble *obj-y gldouble *obj-z)) +(defun-ogl (* :void) "gl-util" "gluNewTess" ()) +(defun-ogl :void "gl-util" "gluDeleteTess" (:void *tess)) +(defun-ogl :void "gl-util" "gluTessBeginContour" (:void *tess)) +(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" "gluTessProperty" (:void *tess GLenum which GLdouble data)) +(defun-ogl :void "gl-util" "gluTessVertex" (:void *tess GLdouble *location GLvoid *data)) +(defun-ogl :void "gl-util" "gluTessCallback" (:void *tess GLenum which :void *callback)) Index: cl-opengl/nehe-14.lisp diff -u cl-opengl/nehe-14.lisp:1.1 cl-opengl/nehe-14.lisp:1.2 --- cl-opengl/nehe-14.lisp:1.1 Wed May 25 05:14:31 2005 +++ cl-opengl/nehe-14.lisp Fri Jul 8 18:26:47 2005 @@ -29,7 +29,7 @@ (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) @@ -42,7 +42,7 @@ (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.0) + (gl-scalef 0.002 0.003 0.002) ;; Pulsing Colors Based On The Rotation (gl-color3f (* 1.0f0 (cos (/ g_rot 20.0f0))) @@ -54,6 +54,33 @@ (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) (glut-swap-buffers) Index: cl-opengl/ogl-macros.lisp diff -u cl-opengl/ogl-macros.lisp:1.1 cl-opengl/ogl-macros.lisp:1.2 --- cl-opengl/ogl-macros.lisp:1.1 Wed May 25 05:14:31 2005 +++ cl-opengl/ogl-macros.lisp Fri Jul 8 18:26:47 2005 @@ -41,6 +41,16 @@ (funcall matrix-fn)) (gl-pop-matrix))) + +(defparameter *matrix-mode* GL_MODELVIEW) +(defmacro with-matrix-mode (mode &body body) + `(unwind-protect + (let ((*matrix-mode* ,mode)) + (glMatrixMode *matrix-mode*) + ,@body) + (glMatrixMode *matrix-mode*))) + + #+debugversion (defun call-with-matrix (load-identity-p matrix-fn matrix-code) (let ((mm-pushed (ogl::get-matrix-mode)) @@ -83,6 +93,21 @@ (funcall attrib-fn) (glec :with-attrib)) (gl-pop-attrib) + )) + +(defmacro with-client-attrib ((&rest attribs) &body body) + `(call-with-client-attrib + ,(apply '+ (mapcar 'symbol-value attribs)) + (lambda () ,@body))) + +(defun call-with-client-attrib (attrib-mask attrib-fn) + (gl-push-client-attrib attrib-mask) + (glec :with-client-attrib-push) + (unwind-protect + (prog1 + (funcall attrib-fn) + (glec :with-client-attrib)) + (gl-pop-client-attrib) )) (defvar *gl-begun*) Index: cl-opengl/ogl-utils.lisp diff -u cl-opengl/ogl-utils.lisp:1.2 cl-opengl/ogl-utils.lisp:1.3 --- cl-opengl/ogl-utils.lisp:1.2 Wed Jun 15 23:09:09 2005 +++ cl-opengl/ogl-utils.lisp Fri Jul 8 18:26:47 2005 @@ -205,7 +205,7 @@ (defun ogl-pen-move (x y) ;;(ukt::trc "ogl-pen-moving" x y) - (gl-bitmap 0 0 0 0 x y)) + (gl-bitmap 0 0 0 0 x y (uffi:make-null-pointer '(:array :cstring)))) (defclass ogl-texture () ((texture-name :accessor texture-name :initform nil)

1 0

[cello-cvs] CVS update: cello/cellodemo/cellodemo.asd cello/cellodemo/cellodemo.lisp cello/cellodemo/cellodemo.lpr cello/cellodemo/cll.lisp cello/cellodemo/demo-window.lisp cello/cellodemo/hedron-decoration.lisp cello/cellodemo/hedron-render.lisp cello/cellodemo/install-notes.txt cello/cellodemo/light-panel.lisp cello/cellodemo/tutor-geometry.lisp cello/cellodemo/virtual-human.lisp
by ktilton＠common-lisp.net 05 Jul '05

05 Jul '05

Update of /project/cello/cvsroot/cello/cellodemo In directory common-lisp.net:/tmp/cvs-serv18729/cellodemo Added Files: cellodemo.asd cellodemo.lisp cellodemo.lpr cll.lisp demo-window.lisp hedron-decoration.lisp hedron-render.lisp install-notes.txt light-panel.lisp tutor-geometry.lisp virtual-human.lisp Log Message: Filling in omitted subdirectory Date: Tue Jul 5 19:00:29 2005 Author: ktilton

1 0

[cello-cvs] CVS update: cl-opengl/glut-osx/ogl-macros.lisp
by ktilton＠common-lisp.net 18 Jun '05

18 Jun '05

Update of /project/cello/cvsroot/cl-opengl/glut-osx In directory common-lisp.net:/tmp/cvs-serv6745/glut-osx Added Files: ogl-macros.lisp Log Message: OSX merge Date: Sat Jun 18 16:56:47 2005 Author: ktilton

1 0

[cello-cvs] CVS update: cl-opengl/glut-osx/glut-execute.lisp cl-opengl/glut-osx/glut-ftgl.lisp cl-opengl/glut-osx/glut-magick.lisp cl-opengl/glut-osx/openmcl-init.lisp cl-opengl/glut-osx/tools-init.lisp
by ktilton＠common-lisp.net 17 Jun '05

17 Jun '05

Update of /project/cello/cvsroot/cl-opengl/glut-osx In directory common-lisp.net:/tmp/cvs-serv28605/glut-osx Added Files: glut-execute.lisp glut-ftgl.lisp glut-magick.lisp openmcl-init.lisp tools-init.lisp Log Message: OSX merge Date: Fri Jun 17 02:17:09 2005 Author: ktilton

1 0

[cello-cvs] CVS update: Directory change: cl-opengl/glut-osx
by ktilton＠common-lisp.net 17 Jun '05

17 Jun '05

Update of /project/cello/cvsroot/cl-opengl/glut-osx In directory common-lisp.net:/tmp/cvs-serv27737/glut-osx Log Message: Directory /project/cello/cvsroot/cl-opengl/glut-osx added to the repository Date: Fri Jun 17 02:14:46 2005 Author: ktilton New directory cl-opengl/glut-osx added

1 0