cello-cvs August 2006

cello-cvs@common-lisp.net

2 participants
51 discussions

[cello-cvs] CVS cello/cl-openal
by ktilton 31 Aug '06

31 Aug '06

Update of /project/cello/cvsroot/cello/cl-openal In directory clnet:/tmp/cvs-serv29491/cl-openal Modified Files: cl-openal-init.lisp cl-openal.lpr Log Message: important fixes to cl-magick and cello demo nehe-06 --- /project/cello/cvsroot/cello/cl-openal/cl-openal-init.lisp 2006/08/24 07:54:23 1.6 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal-init.lisp 2006/08/31 17:34:49 1.7 @@ -63,7 +63,7 @@ (format t "~&clear AL error code ~a" (al-get-error)) - (let ((l-zip (make-ff-array al-float 0 0 0)) + (let ((l-zip (make-ff-array al-float 10 0 0)) (l-ori (make-ff-array al-float 0 0 -1 0 1 0))) (al-listenerfv al_position l-zip) --- /project/cello/cvsroot/cello/cl-openal/cl-openal.lpr 2006/08/24 17:35:08 1.8 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal.lpr 2006/08/31 17:34:49 1.9 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Aug 17, 2006 12:24)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*- (in-package :cg-user)

1 0

[cello-cvs] CVS cello/cffi-extender
by ktilton 31 Aug '06

31 Aug '06

Update of /project/cello/cvsroot/cello/cffi-extender In directory clnet:/tmp/cvs-serv29491/cffi-extender Modified Files: arrays.lisp cffi-extender.lpr Log Message: important fixes to cl-magick and cello demo nehe-06 --- /project/cello/cvsroot/cello/cffi-extender/arrays.lisp 2006/07/06 22:09:10 1.2 +++ /project/cello/cvsroot/cello/cffi-extender/arrays.lisp 2006/08/31 17:34:47 1.3 @@ -80,6 +80,14 @@ :ptr ptr) *fgn-mem*)))) +(defun fgn-free-all () + (loop for f in *fgn-mem* do + (foreign-free (fgn-ptr f)) + finally (setf *fgn-mem* nil))) + +#+go +(fgn-free-all) + (defun fgn-free (&rest fgn-ptrs) ;; (print `(fgn-free freeing ,@fgn-ptrs)) (let ((start (copy-list fgn-ptrs))) --- /project/cello/cvsroot/cello/cffi-extender/cffi-extender.lpr 2006/08/21 04:28:27 1.4 +++ /project/cello/cvsroot/cello/cffi-extender/cffi-extender.lpr 2006/08/31 17:34:47 1.5 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Jul 24, 2006 15:27)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*- (in-package :cg-user)

1 0

[cello-cvs] CVS cello/cl-magick
by ktilton 31 Aug '06

31 Aug '06

Update of /project/cello/cvsroot/cello/cl-magick In directory clnet:/tmp/cvs-serv29491/cl-magick Modified Files: cl-magick.lisp cl-magick.lpr wand-image.lisp Log Message: important fixes to cl-magick and cello demo nehe-06 --- /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2006/08/28 21:45:25 1.10 +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2006/08/31 17:34:48 1.11 @@ -20,7 +20,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Id: cl-magick.lisp,v 1.10 2006/08/28 21:45:25 ktilton Exp $ +;;; $Id: cl-magick.lisp,v 1.11 2006/08/31 17:34:48 ktilton Exp $ (defpackage :cl-magick @@ -34,7 +34,7 @@ #+kt-opengl #:kt-opengl ;; wands as opengl textures ) - (:export #:wand-manager #:wand-ensure-typed + (:export #:cl-magick-init #:cl-magick-reset #:wand-manager #:wand-ensure-typed #:wands-clear #:wand-pixels #:wand-texture #:wand-render #:image-size #:wand-texture-activate #:xim @@ -77,27 +77,23 @@ (cffi:define-foreign-library Wand (:darwin (:or "/usr/local/lib/libWand.dylib"))) -;------------------------------------------------------------------- +;; Order matters! First, load Wand then Magick on Darwin -(defun cl-magick-init () - (or *imagick-dll-loaded* - (progn - ;(print "clearing magick wands") - ;(wands-clear) - - ;; Order matters! First, load Wand then Magick on Darwin - #+macosx - (cffi:use-foreign-library Wand) +#+macosx +(cffi:use-foreign-library Wand) - (assert (setq *imagick-dll-loaded* - (cffi:use-foreign-library Magick)) - () "Unable to load imagick" ) - (print `(magick-copyright ,(magick-get-copyright))) - (print `(magick-version ,(magick-get-version *mgk-version*))) - *imagick-dll-loaded*))) +(cffi:use-foreign-library Magick) + +;------------------------------------------------------------------- -#+test -(cl-magick-init) +(defun cl-magick-init ()) ;; vestigial + +(defun cl-magick-reset () + (wands-clear) + #+shhh (progn + (print `(magick-copyright ,(magick-get-copyright))) + (print `(magick-version ,(magick-get-version *mgk-version*)))) + ) (defun wands-loaded () *wands-loaded*) @@ -113,14 +109,14 @@ (when file-path$ (cl-magick-init) (let ((key (list* wand-type (namestring file-path$) iargs))) - (or (let ((old nil #+nope (cdr (assoc key (wands-loaded) :test 'equal)))) ;;/// primitive test - (when old + (or (let ((old (cdr (assoc key (wands-loaded) :test 'equal)))) ;;/// primitive test + #+shhhh (when old (print `(wand-ensure-typed re-using prior load ,wand-type ,file-path$))) old) (let ((wi (apply 'make-instance wand-type :file-path$ file-path$ iargs))) - ;;(print `(wand-ensure-typed forced to load ,wand-type ,file-path$)) + (print `(wand-ensure-typed forced-to-load ,wand-type ,file-path$)) (push (cons key wi) (wands-loaded)) wi) (error "Unable to load image file ~a" file-path$))))) --- /project/cello/cvsroot/cello/cl-magick/cl-magick.lpr 2006/08/21 04:28:28 1.6 +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lpr 2006/08/31 17:34:48 1.7 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Jul 24, 2006 15:27)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cello/cvsroot/cello/cl-magick/wand-image.lisp 2006/08/28 18:42:26 1.6 +++ /project/cello/cvsroot/cello/cl-magick/wand-image.lisp 2006/08/31 17:34:48 1.7 @@ -99,7 +99,7 @@ (let* ((columns (- last-col first-col)) (rows (- last-row first-row)) (pixels (fgn-alloc :unsigned-char (* 3 columns rows) :wand-image))) - + (assert (not (zerop pixels))() "wand-get-image-pixels > fgn-alloc of ~a bytes failed" (* 3 columns rows)) ;;(print (list "wand-get-image-pixels got" wand (* 3 columns rows) pixels)) ;; frgo: debug ... ;;(cells:trc "image format" wand (magick-get-image-format wand)) ;; frgo:debug... (magick-get-image-pixels wand first-col first-row columns rows "RGB" 0 pixels )

1 0

[cello-cvs] CVS cello
by ktilton 31 Aug '06

31 Aug '06

Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv29491 Modified Files: nehe-06.lisp window-utilities.lisp Log Message: important fixes to cl-magick and cello demo nehe-06 --- /project/cello/cvsroot/cello/nehe-06.lisp 2006/07/24 05:00:35 1.8 +++ /project/cello/cvsroot/cello/nehe-06.lisp 2006/08/31 17:34:47 1.9 @@ -23,7 +23,11 @@ (defparameter zrot 0.0f0) (defparameter *skin6* nil) +(defvar *jmc-font* ) + (defun nehe-06 () ;; ACL project manager needs a zero-argument function, in project package + (setf *jmc-font* (ftgl-make :texture 'sylfaen 48 96 18)) + (cl-magick-reset) (test-window 'nehe-06-demo)) (defmodel nehe-06-demo (window) @@ -79,7 +83,7 @@ (gl-load-identity)))) -(defparameter *jmc-font* (ftgl-make :texture 'sylfaen 48 96 18)) + (defmethod togl-display-using-class ((self nehe06)) (gl-load-identity) --- /project/cello/cvsroot/cello/window-utilities.lisp 2006/08/21 04:28:26 1.7 +++ /project/cello/cvsroot/cello/window-utilities.lisp 2006/08/31 17:34:47 1.8 @@ -98,6 +98,8 @@ (let ((,item-var (elt ,list (- ,len ,times-var 1)))) ,@body))))) +(export! find-ix-under) + (defun find-ix-under (self os-pos &key (test #'true)) (when (and (visible self) (not (collapsed self)))

1 0

[cello-cvs] CVS cello/kt-opengl
by ktilton 28 Aug '06

28 Aug '06

Update of /project/cello/cvsroot/cello/kt-opengl In directory clnet:/tmp/cvs-serv27660/kt-opengl Modified Files: gl-def.lisp gl-functions.lisp glu-functions.lisp kt-opengl.lisp kt-opengl.lpr ogl-macros.lisp Log Message: --- /project/cello/cvsroot/cello/kt-opengl/gl-def.lisp 2006/07/03 00:35:16 1.2 +++ /project/cello/cvsroot/cello/kt-opengl/gl-def.lisp 2006/08/28 21:45:27 1.3 @@ -27,7 +27,7 @@ (progn ;;(cells::count-it ,(intern (string-upcase name$) :keyword)) ;;(format t "~&~(~a~) ~{ ~a~}" ,name$ (list ,@(loop for (nil arg) on type-args by #'cddr collecting arg))) - (glec ',(intern name$))))) + #+nogoodinsideglbegin (glec ',(intern name$))))) (defun aforef (o n) (cffi-uffi-compat:deref-array o '(:array :int) n)) --- /project/cello/cvsroot/cello/kt-opengl/gl-functions.lisp 2006/08/21 04:28:29 1.3 +++ /project/cello/cvsroot/cello/kt-opengl/gl-functions.lisp 2006/08/28 21:45:27 1.4 @@ -24,6 +24,7 @@ (defparameter *ogl-listing-p* nil) + (defun-ogl :void "open-gl" "glFlush" ()) (defun-ogl :void "open-gl" "glMaterialfv" (glenum face glenum pname glfloat *params)) @@ -32,12 +33,14 @@ (defun-ogl :void "open-gl" "glBegin" (glenum mode )) (defun-ogl :void "open-gl" "glEnd" ( )) + (defun-ogl :void "open-gl" "glVertex2d" (gldouble x gldouble y )) (defun-ogl :void "open-gl" "glVertex2f" (glfloat x glfloat y )) (defun-ogl :void "open-gl" "glVertex2i" (glint x glint y )) (defun-ogl :void "open-gl" "glVertex2s" (glshort x glshort y )) (defun-ogl :void "open-gl" "glVertex3d" (gldouble x gldouble y gldouble z )) (defun-ogl :void "open-gl" "glVertex3f" (glfloat x glfloat y glfloat z )) + (defun-ogl :void "open-gl" "glVertex3i" (glint x glint y glint z )) (defun-ogl :void "open-gl" "glVertex3s" (glshort x glshort y glshort z )) (defun-ogl :void "open-gl" "glVertex4d" (gldouble x gldouble y gldouble z gldouble w )) --- /project/cello/cvsroot/cello/kt-opengl/glu-functions.lisp 2006/07/03 00:35:16 1.2 +++ /project/cello/cvsroot/cello/kt-opengl/glu-functions.lisp 2006/08/28 21:45:27 1.3 @@ -130,6 +130,7 @@ (dfc GLU_U_STEP 100206) (dfc GLU_V_STEP 100207) + ;;; NurbsSampling */ (dfc GLU_PATH_LENGTH 100215) (dfc GLU_PARAMETRIC_ERROR 100216) --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lisp 2006/08/28 18:38:03 1.5 +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lisp 2006/08/28 21:45:27 1.6 @@ -21,7 +21,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Id: kt-opengl.lisp,v 1.5 2006/08/28 18:38:03 fgoenninger Exp $ +;;; $Id: kt-opengl.lisp,v 1.6 2006/08/28 21:45:27 ktilton Exp $ (pushnew :kt-opengl *features*) @@ -62,7 +62,7 @@ #:ogl-bounds #:ogl-scissor-box #:ogl-raster-pos-get #:ogl-pen-move #:with-bitmap-shifted #:texture-name #:ogl-list-cache #:ogl-lists-delete - #:eltgli #:ogl-tex-activate #:gl-name + #:eltgli #:ogl-tex-activate #:gl-name #:glec #:gl-get-integers #:gl-get-floats @@ -80,25 +80,45 @@ (defvar *selecting*) -(define-foreign-library OpenGL - (:windows (:or (namestring +(defparameter *win32-opengl-loc* (namestring (make-pathname ;;#+lispworks :host #-lispworks :device "c" :directory '(:absolute "windows" "system32") :name "opengl32" - :type "dll")))) - (:darwin (:or (:framework "OpenGL")))) + :type "dll"))) -(define-foreign-library GLU - (:windows (:or (namestring +(defparameter *win32-glu-loc* (namestring (make-pathname ;;#+lispworks :host #-lispworks :device "c" :directory '(:absolute "windows" "system32") :name "opengl32" - :type "dll"))))) + :type "dll"))) + +(define-foreign-library OpenGL + (:windows (:or "/windows/system32/opengl32.dll")) + (:darwin (:or (:framework "OpenGL")))) + +(define-foreign-library GLU + (:windows (:or "/windows/system32/glu32.dll"))) (defparameter *opengl-dll* nil) +(defun kt-opengl-init () + (unless *opengl-dll* + (progn + (let ((opengl-loaded-p + (use-foreign-library OpenGL)) + (glu-loaded-p + #+macosx + t ;; on Mac OS X, no explicit loading of GLU needed. + #-macosx + (use-foreign-library GLU))) + (assert (and opengl-loaded-p glu-loaded-p)) + (setf *opengl-dll* t))))) + +(eval-when (:load-toplevel :execute) + (kt-opengl-init)) + (defun gl-boolean-test (value) #+allegro (not (eql value #\null)) #-allegro (not (zerop value))) --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lpr 2006/08/21 04:28:29 1.4 +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lpr 2006/08/28 21:45:28 1.5 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Jul 24, 2006 15:27)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cello/cvsroot/cello/kt-opengl/ogl-macros.lisp 2006/08/28 18:37:22 1.7 +++ /project/cello/cvsroot/cello/kt-opengl/ogl-macros.lisp 2006/08/28 21:45:28 1.8 @@ -47,7 +47,7 @@ (defun call-with-matrix (load-identity-p matrix-fn matrix-code) (let* ((mm-pushed (get-matrix-mode)) (sd-pushed (get-stack-depth mm-pushed))) - (cells:wtrc (0 100 "with-matrix starts with mode" (matrix-mode-symbol mm-pushed) :depth sd-pushed) + (progn ;; cells:wtrc (0 100 "with-matrix starts with mode" (matrix-mode-symbol mm-pushed) :depth sd-pushed) (gl-push-matrix) (unwind-protect (progn @@ -59,7 +59,7 @@ (assert (eql mm-pushed (get-matrix-mode))() "matrix-mode left as ~a instead of ~a by form ~a" (ogl::get-matrix-mode) mm-pushed matrix-code) - (cells:trc "poppping matrix!!!!!" (matrix-mode-symbol (get-matrix-mode)) :from-depth (get-stack-depth (get-matrix-mode))) + (cells:trc nil "poppping matrix!!!!!" (matrix-mode-symbol (get-matrix-mode)) :from-depth (get-stack-depth (get-matrix-mode))) (gl-pop-matrix) (assert (eql sd-pushed (get-stack-depth mm-pushed))() "matrix depth deviated ~d during ~a" @@ -93,21 +93,26 @@ (prog1 (funcall attrib-fn) (glec :with-client-attrib)) - (gl-pop-client-attrib))) + (gl-pop-client-attrib) + (glec :with-client-attrib-pop))) (defvar *gl-begun*) (defvar *gl-stop*) (defmacro with-gl-begun ((what) &body body) - `(progn - (when (boundp '*gl-begun*) - (setf *gl-stop* t) - (break ":nestedbegin")) - (let ((*gl-begun* t)) - (gl-begin ,what) - ,@body - (gl-end) - (glec :with-gl-begun)))) + `(call-with-gl-begun ,what (lambda () ,@body))) + +(defun call-with-gl-begun (what begun-fn) + (when (boundp '*gl-begun*) + (setf *gl-stop* t) + (break ":nestedbegin")) + (progn + (glec :with-gl-begun-BEFORE) + (let ((*gl-begun* t)) + (gl-begin what) + (funcall begun-fn) + (gl-end)) + (glec :with-gl-begun-exit))) (defmacro with-gensyms ((&rest syms) &body body) `(let ,(loop for sym in syms @@ -122,29 +127,22 @@ ,@body (gl-translatef (- ,dx)(- ,dy)(- ,dz)))))) -(defun kt-opengl-init () - (unless *opengl-dll* - (progn - (let ((opengl-loaded-p - (use-foreign-library OpenGL)) - (glu-loaded-p - #+macosx - t ;; on Mac OS X, no explicit loading of GLU needed. - #-macosx - (use-foreign-library GLU))) - (assert (and opengl-loaded-p glu-loaded-p)) - (setf *opengl-dll* t))))) -(eval-when (:load-toplevel :execute) - (kt-opengl-init)) -(defun glec (&optional (id :anon)) +(defun kt-opengl-reset () + (loop for ec = (glgeterror) + for n below 10 + when (zerop ec) do (cells::trc "kt-opengl-reset sees zero error code") + (loop-finish) + do (cells::trc "kt-opengl-init sees error" ec))) + +(defun glec (&optional (id :anon) announce-success) (if (and (boundp '*gl-begun*) *gl-begun*) - (progn #+shhh (cells:trc "not checking error inside gl-begin" id)) + (progn (cells:trc nil "not checking error inside gl.begin" id)) (let ((e (glgeterror))) (if (zerop e) - (unless t ;; (find id '(glutcheckloop glutgetwindow)) - (print `(cool ,id))) + (when announce-success + (print `(OpenGL cool ,id))) (if t ;; (null (find id '(glutInitDisplayMode glutInitWindowSize))) (if (boundp '*gl-stop*) (cells:trc "error but *gl-stop* already bound" e id)

1 0

[cello-cvs] CVS cello/cl-magick
by ktilton 28 Aug '06

28 Aug '06

Update of /project/cello/cvsroot/cello/cl-magick In directory clnet:/tmp/cvs-serv27660/cl-magick Modified Files: cl-magick.lisp Log Message: --- /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2006/08/26 21:46:21 1.9 +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2006/08/28 21:45:25 1.10 @@ -20,7 +20,8 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Id: cl-magick.lisp,v 1.9 2006/08/26 21:46:21 fgoenninger Exp $ +;;; $Id: cl-magick.lisp,v 1.10 2006/08/28 21:45:25 ktilton Exp $ + (defpackage :cl-magick (:nicknames :mgk)

1 0

[cello-cvs] CVS cello/cl-ftgl
by ktilton 28 Aug '06

28 Aug '06

Update of /project/cello/cvsroot/cello/cl-ftgl In directory clnet:/tmp/cvs-serv27660/cl-ftgl Modified Files: cl-ftgl.lisp cl-ftgl.lpr Log Message: --- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2006/08/26 16:07:35 1.11 +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2006/08/28 21:45:24 1.12 @@ -20,7 +20,10 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Header: /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp,v 1.11 2006/08/26 16:07:35 fgoenninger Exp $ +;;; $Header: /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp,v 1.12 2006/08/28 21:45:24 ktilton Exp $ + +(eval-when (:compile-toplevel :load-toplevel) + (pushnew :cl-ftgl *features*)) (defpackage #:cl-ftgl (:nicknames #:ftgl) @@ -65,7 +68,7 @@ (defparameter *ftgl-font-pathnames-list* - #+(or win32 windows) + #+(or win32 windows mswindows) (list (make-pathname :directory @@ -87,12 +90,12 @@ '(:absolute "Library" "Fonts")) (make-pathname :directory - '(:relative "~" "Library" "Fonts"))) -) + '(:relative "~" "Library" "Fonts"))) + ) (defparameter *ftgl-font-types-list* ;; list of font types ;; (font filename endings) - #+(or win32 windows) + #+(or win32 windows mswindows) '("ttf") #+linux @@ -114,7 +117,7 @@ pathname))) (if (probe-file pn) (progn - (format t "~%*** FIND-FONT-FILE: Result = ~A~%" pn) + ;;(format t "~%*** FIND-FONT-FILE: Result = ~A~%" pn) (return-from pn-loop pn))))))) ;; ---------------------------------------------------------------------------- @@ -174,9 +177,28 @@ (defun cl-ftgl-reset () #-(or mcl macosx) (setq *ftgl-loaded-p* nil) - + (cells::trc "nailing fonts loaded!!!!!!!!!!!!!") (setq *ftgl-fonts-loaded* nil)) +(defmacro dbgftgl (tag &body body) + (declare (ignorable tag)) + `(progn + #+nahhh (unless (boundp '*gl-begun*) + (assert (zerop (glgeterror)))) + #+nahhh (loop for (key . fonts) in (mathx::mp-fonts mathx::*font-node*) + when (eq key 'mathx::mathvar) + do (loop for font across fonts + when (or (eql 12 (ftgl-size font))(ftgl-ifont font)) + do (cells::trc nil "dbgftgl sees ifont" ,tag (ftgl-face font)(ftgl-size font)(ftgl-ifont font)))) + (progn ;; cells:wtrc (0 100 "dbgftgl" ,tag) + (ftgl-assert-opengl-context) + (unless (boundp '*gl-begun*) (glec :dbgftgl-entry)) + (prog1 + (progn ,@body) + (unless (boundp '*gl-begun*) + (progn + (glec :dbgftgl-post-body))))))) + #+test (progn (cl-ftgl-init) @@ -189,19 +211,24 @@ (defun cl-ftgl-init () (unless *ftgl-loaded-p* - (assert (setq *ftgl-loaded-p* (use-foreign-library FTGL)))) - (format *debug-io* "~%*** CL-FTGL-INIT: Loaded: ~S~%" - *ftgl-loaded-p*)) ;; frgo: Debug ... + (assert (setq *ftgl-loaded-p* (use-foreign-library FTGL))) + (format *debug-io* "~%*** CL-FTGL-INIT: Loaded: ~S~%" + *ftgl-loaded-p*))) (defun ftgl-font-ensure (type face size target-res &optional (depth 0)) - (let ((fspec (list type face size target-res depth))) - (or (cdr (assoc fspec *ftgl-fonts-loaded* :test 'equal)) + (let* ((fspec (list type face size target-res depth)) + (match (cdr (assoc fspec *ftgl-fonts-loaded* :test 'equal)))) + #+shh (if match + (cells:trc "ftgl-font-ensure finds match" fspec (ftgl-ifont match)) + (cells:trc "ftgl-font-ensure NO match" fspec )) + (or match (let ((f (apply 'ftgl-make fspec))) (push (cons fspec f) *ftgl-fonts-loaded*) + (cells:trc nil "ftgl-font-ensure new font spec ifont" fspec (ftgl-ifont f)) f)))) (defun ftgl-make (type face size target-res &optional (depth 0)) - (print (list "ftgl-make entry" type face size)) + ;;(print (list "ftgl-make entry" type face size)) (funcall (ecase type (:bitmap 'make-ftgl-bitmap) (:pixmap 'make-ftgl-pixmap) @@ -217,12 +244,24 @@ ;; --------- ftgl structure ----------------- + (defstruct ftgl + dbg face size target-res depth descender ascender (widths (make-array 256 :initial-element nil)) ft-metrics - ifont) + (ifont nil)) + +(defun dbgfont (font calltag) + (declare (ignore font calltag)) +;;; (cells::trc "dbgfont" calltag (ftgl-dbg font) (ftgl-face font)(ftgl-size font)(ftgl-ifont font)) +;;; (unless (find font mathx::*font-node-all*) +;;; (cells::trc "dbgfont unknown!!!!! " calltag ) +;;; (dolist (f mathx::*font-node-all*) +;;; (cells::trc "known" (ftgl-dbg f)(ftgl-face f)(ftgl-size f))) +;;; (break "odd font")) + ) (defun ftgl-assert-opengl-context () ;; use when debugging FTGL being hit before opengl context estanblished @@ -230,10 +269,11 @@ ) (defun ftgl-char-width (f c) - (ftgl-assert-opengl-context) - (or (aref (ftgl-widths f) (char-code c)) - (setf (aref (ftgl-widths f) (char-code c)) - (ftgl-string-length f (string c))))) + (assert (zerop (glgeterror))) + (dbgftgl :ftgl-char-width + (or (aref (ftgl-widths f) (char-code c)) + (setf (aref (ftgl-widths f) (char-code c)) + (ftgl-string-length f (string c)))))) (defstruct (ftgl-disp (:include ftgl)) ready-p) @@ -271,52 +311,54 @@ (xftgl) (defun ftgl-get-ascender (font) - (ftgl-assert-opengl-context) - (or (ftgl-ascender font) - (setf (ftgl-ascender font) - (fgc-ascender (ftgl-get-metrics-font font))))) + (cells:trc nil "ftgl-get-ascender" (ftgl-ifont font)) + (dbgftgl :ftgl-get-ascender + (or (ftgl-ascender font) + (setf (ftgl-ascender font) + (fgc-ascender (ftgl-get-metrics-font font)))))) (defun ftgl-get-descender (font) - (ftgl-assert-opengl-context) - (or (ftgl-descender font) - (setf (ftgl-descender font) - (fgc-descender (ftgl-get-metrics-font font))))) + (cells:trc nil "ftgl-get-descender" (ftgl-ifont font)) + (dbgftgl :ftgl-get-descender + (or (ftgl-descender font) + (setf (ftgl-descender font) + (fgc-descender (ftgl-get-metrics-font font)))))) (defun ftgl-height (f) - (ftgl-assert-opengl-context) - (- (ftgl-get-ascender f) - (ftgl-get-descender f))) + (cells:trc nil "ftgl-height" (ftgl-ifont f)) + (dbgftgl :ftgl-height + (- (ftgl-get-ascender f) + (ftgl-get-descender f)))) (defun ftgl-get-display-font (font) - (let ((cf (ftgl-get-metrics-font font))) - (assert cf) - ; (print (list "FTGL-GET-DISPLAY-FONT sees" (ftgl-disp-ready-p font))) - ;; (print (list "FTGL-GET-DISPLAY-FONT sees" (ftgl-ready font))) - - (Unless (ftgl-ready font) - ; (when *ogl-listing-p* - ; (cells::c-break "bad time #1 for sizing? ~a ~a" *ogl-listing-p* font)) - (setf (ftgl-ready font) t) - (typecase font - (ftgl-extruded - #+nyet (let ((*ogl-listing-p* t)) - (trc nil "ftgl-get-display-font> building glyphs for" font) - - (fgc-build-glyphs cf) - (trc nil "ftgl-get-display-font> glyphs built OK for" font))) - (ftgl-texture - #+no (fgc-set-face-size cf (ftgl-size font) (ftgl-target-res font))) - (ftgl-pixmap - #+no (fgc-set-face-size cf (ftgl-size font) (ftgl-target-res font))))) - cf)) + (cells:trc nil "ftgl-get-display-font" (ftgl-ifont font)) + (dbgftgl :ftgl-get-display-font + (let ((cf (ftgl-get-metrics-font font))) + (assert cf) + ; (print (list "FTGL-GET-DISPLAY-FONT sees" (ftgl-disp-ready-p font))) + ;; (print (list "FTGL-GET-DISPLAY-FONT sees" (ftgl-ready font))) + + (Unless (ftgl-ready font) + ; (when *ogl-listing-p* + ; (cells::c-break "bad time #1 for sizing? ~a ~a" *ogl-listing-p* font)) + (setf (ftgl-ready font) t) + (typecase font + (ftgl-extruded + #+nyet (let ((*ogl-listing-p* t)) + (cells:trc nil "ftgl-get-display-font> building glyphs for" font) + + (fgc-build-glyphs cf) + (cells:trc nil "ftgl-get-display-font> glyphs built OK for" font))) + (ftgl-texture + #+no (fgc-set-face-size cf (ftgl-size font) (ftgl-target-res font))) + (ftgl-pixmap + #+no (fgc-set-face-size cf (ftgl-size font) (ftgl-target-res font))))) + (glec :ftgl-get-display-font) + cf))) (defun ftgl-get-metrics-font (font) - (prog1 - (or (ftgl-ifont font) - (setf (ftgl-ifont font) (ftgl-font-make font))) - - ;; (print (list "ftgl-get-metrics-font: exit" font)) ; frgo, ADDED: debug... - )) + (or (ftgl-ifont font) + (setf (ftgl-ifont font) (ftgl-font-make font)))) (defun ftgl-font-make (font) (let ((path (find-font-file font))) @@ -326,7 +368,6 @@ (if f (progn (fgc-set-face-size f (ftgl-size font) (ftgl-target-res font)) -;; (setf (ftgl-ifont font) f) f) (error "cannot load ~a font ~a" (type-of font) fpath))) (error "Font not found: ~a" path)))) @@ -334,17 +375,23 @@ (defmethod ftgl-render (font s) (assert font) (assert (stringp s)) - (when font - (let ((df (ftgl-get-display-font font))) - (if df - (fgc-render df s) - (break "whoa, no display font for ~a" font))))) + (dbgfont font :ftgl-render) + (dbgftgl :ftgl-render + (when font + (let ((df (ftgl-get-display-font font))) + (ukt:trc nil "ftgl-render ing" df s (ftgl-face font) (ftgl-size font)) + (if df + (fgc-render df s) + (break "whoa, no display font for ~a" font)))))) (defmethod ftgl-render :before ((font ftgl-texture) s) (declare (ignorable s)) - (gl-enable gl_texture_2d) - (gl-enable gl_blend) - (gl-disable gl_lighting)) + (dbgfont font :ftgl-render-before) + + (dbgftgl :ftgl-render + (gl-enable gl_texture_2d) + (gl-enable gl_blend) + (gl-disable gl_lighting))) (defmethod fgc-font-make :before (font fpath) (declare (ignore font fpath)) @@ -357,7 +404,7 @@ (fgc-bitmap-make fpath)) (defmethod fgc-font-make ((font ftgl-texture) fpath) - (format t "~%*** FGC-FONT-MAKE: fpath = ~A~%" fpath) + ;;(format t "~%*** FGC-FONT-MAKE: fpath = ~A~%" fpath) (fgc-texture-make fpath)) (defmethod fgc-font-make ((font ftgl-extruded) fpath) --- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2006/08/21 04:28:27 1.7 +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2006/08/28 21:45:24 1.8 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Aug 17, 2006 12:24)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*- (in-package :cg-user)

1 0

[cello-cvs] CVS cello
by ktilton 28 Aug '06

28 Aug '06

Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv27660 Modified Files: application.lisp cello-ftgl.lisp cello.lisp cello.lpr image.lisp ix-opengl.lisp ix-paint.lisp ix-togl.lisp Log Message: --- /project/cello/cvsroot/cello/application.lisp 2006/07/03 00:35:12 1.5 +++ /project/cello/cvsroot/cello/application.lisp 2006/08/28 21:45:22 1.6 @@ -24,10 +24,13 @@ (ffx-reset) (cells-reset 'tk-user-queue-handler) (makunbound 'ogl::*gl-stop*) + ;(xftgl) + ;(cl-ftgl-reset) ;; new 2006-08-28 in face of weird OGL 1282 when new chars hit in ratios (when system-type (setf *sys* (make-instance system-type :md-name 'mgsys))) (values)) + (defmodel mg-system (family) ( (main-window :initarg :main-window :initform (c-in nil) :accessor main-window) --- /project/cello/cvsroot/cello/cello-ftgl.lisp 2006/06/11 13:32:24 1.5 +++ /project/cello/cvsroot/cello/cello-ftgl.lisp 2006/08/28 21:45:22 1.6 @@ -39,6 +39,7 @@ string))) (defun font-ftgl-ensure (mode face size) ;; ///sorry about the silly naming + (trc "font-ftgl-ensure requesting" mode face size) (ftgl-font-ensure mode face size (cs-target-res))) (defmodel font-id (ct-toggle ix-text) --- /project/cello/cvsroot/cello/cello.lisp 2006/08/26 21:44:03 1.11 +++ /project/cello/cvsroot/cello/cello.lisp 2006/08/28 21:45:22 1.12 @@ -14,7 +14,9 @@ |# -;;; $Id: cello.lisp,v 1.11 2006/08/26 21:44:03 fgoenninger Exp $ + +;;; $Id: cello.lisp,v 1.12 2006/08/28 21:45:22 ktilton Exp $ + ;;; ============================================================================ ;;; PACKAGE DEFINITION --- /project/cello/cvsroot/cello/cello.lpr 2006/08/21 04:28:26 1.11 +++ /project/cello/cvsroot/cello/cello.lpr 2006/08/28 21:45:22 1.12 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Aug 17, 2006 12:24)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cello/cvsroot/cello/image.lisp 2006/08/21 04:28:26 1.10 +++ /project/cello/cvsroot/cello/image.lisp 2006/08/28 21:45:22 1.11 @@ -105,13 +105,13 @@ :orientation :horizontal)) (defmacro a-stack ((&rest stack-args) &body dd-kids) - `(mk-part ,(copy-symbol 'stk) (ix-stack) + `(mk-part ,(gensym "STAK") (ix-stack) ,@stack-args :fm-parent *parent* :kids (c? (the-kids ,@dd-kids)))) (defmacro a-stack-lazy ((&rest stack-args) &body dd-kids) - `(mk-part ,(copy-symbol 'stk) (ix-stack-lazy) + `(mk-part ,(gensym "STAK") (ix-stack-lazy) ,@stack-args :fm-parent *parent* :kids (c? (the-kids ,@dd-kids)))) --- /project/cello/cvsroot/cello/ix-opengl.lisp 2006/08/21 04:28:26 1.4 +++ /project/cello/cvsroot/cello/ix-opengl.lisp 2006/08/28 21:45:22 1.5 @@ -81,6 +81,7 @@ (defun render (self) (let (*selecting* *render-clip-l* *render-clip-r* *render-clip-t* *render-clip-b*) + (assert (zerop (glgeterror))) (with-metrics (nil nil "ix-paint" self) (trc nil "render" self (^height)) (ix-paint self)))) --- /project/cello/cvsroot/cello/ix-paint.lisp 2006/08/21 04:28:26 1.3 +++ /project/cello/cvsroot/cello/ix-paint.lisp 2006/08/28 21:45:22 1.4 @@ -65,7 +65,7 @@ (with-bitmap-shifted ((px self)(py self)) (gl-translatef (px self) (py self) 0) - + (assert (zerop (glgeterror))) (when n (trc "pushing gl-name" self n) (gl-push-name n)) @@ -90,6 +90,7 @@ (:off (gl-disable gl_lighting))) (gl-enable gl_color_material) + (assert (zerop (glgeterror))) (bif (pre-layer (pre-layer self)) (progn (assert (functionp pre-layer)) @@ -161,6 +162,7 @@ (declare (ignore g-box)) (count-it :render-layer) (count-it :render-layer (type-of key)) + (assert (zerop (glgeterror))) (call-next-method)) --- /project/cello/cvsroot/cello/ix-togl.lisp 2006/08/23 20:21:59 1.6 +++ /project/cello/cvsroot/cello/ix-togl.lisp 2006/08/28 21:45:22 1.7 @@ -231,25 +231,7 @@ (defmethod ctk:togl-create-using-class ((self ix-togl)) (setf (gl-name self) (gl-gen-lists 1)) - (cello-gl-init) ;; clear errors -;;; -;;; #+profile (macrolet ((glm (param num) -;;; (declare (ignore num)) -;;; `(trc ,(symbol-name param) (ogl-get-int ,param)))) -;;; (glm gl_max_list_nesting 0) -;;; (glm gl_max_eval_order #X0000) -;;; (glm gl_max_lights #x3377 ) -;;; (glm gl_max_clip_planes #x3378 ) -;;; (glm gl_max_texture_size #x3379 ) -;;; (glm gl_max_pixel_map_table #x3380 ) -;;; (glm gl_max_attrib_stack_depth #x3381 ) -;;; (glm gl_max_model-view_stack_depth #x3382 ) -;;; (glm gl_max_name_stack_depth #x3383 ) -;;; (glm gl_max_projection_stack_depth #x3384 ) -;;; (glm gl_max_texture_stack_depth #x3385 ) -;;; (glm gl_max_viewport_dims #x3386 ) -;;; ) -;;; + (cello-gl-init) (gl-disable gl_texture_2d) (gl-shade-model gl_smooth) ;; Enable Smooth Shading (gl-clear-depth 1.0f0) ;; Depth Buffer Setup @@ -263,7 +245,23 @@ until (zerop (glGetError)) when (> ct 10) do #-lispworks (c-break "gl-init") - #+lispworks (return-from cello-gl-init))) + #+lispworks (return-from cello-gl-init)) + + (macrolet ((glm (param num) + (declare (ignore num)) + `(trc ,(symbol-name param) (ogl-get-int ,param)))) + (glm gl_max_list_nesting 0) + (glm gl_max_eval_order #X0000) + (glm gl_max_lights #x3377 ) + (glm gl_max_clip_planes #x3378 ) + (glm gl_max_texture_size #x3379 ) + (glm gl_max_pixel_map_table #x3380 ) + (glm gl_max_attrib_stack_depth #x3381 ) + (glm gl_max_model-view_stack_depth #x3382 ) + (glm gl_max_name_stack_depth #x3383 ) + (glm gl_max_projection_stack_depth #x3384 ) + (glm gl_max_texture_stack_depth #x3385 ) + (glm gl_max_viewport_dims #x3386 ))) (defmethod ix-selectable ((self ix-togl)) t)

1 0

[cello-cvs] CVS cello/cl-magick
by fgoenninger 28 Aug '06

28 Aug '06

Update of /project/cello/cvsroot/cello/cl-magick In directory clnet:/tmp/cvs-serv21180 Modified Files: wand-image.lisp Log Message: Changed: Re-arranged class definition code (beautifying only). --- /project/cello/cvsroot/cello/cl-magick/wand-image.lisp 2006/08/22 16:12:35 1.5 +++ /project/cello/cvsroot/cello/cl-magick/wand-image.lisp 2006/08/28 18:42:26 1.6 @@ -23,12 +23,11 @@ (in-package :cl-magick) (defclass wand-image () - ((direction :initarg :direction :initform :input :accessor direction) - (file-path$ :initarg :file-path$ :accessor file-path$ :initform nil) - (mgk-wand :initarg :mgk-wand :accessor mgk-wand :initform nil) - (image-size :initarg :image-size :accessor image-size :initform nil) - (tile-p :initarg :tile-p :accessor tile-p :initform t) - )) + ((direction :initarg :direction :initform :input :accessor direction) + (file-path$ :initarg :file-path$ :initform nil :accessor file-path$) + (mgk-wand :initarg :mgk-wand :initform nil :accessor mgk-wand) + (image-size :initarg :image-size :initform nil :accessor image-size) + (tile-p :initarg :tile-p :initform t :accessor tile-p))) (defmethod initialize-instance :after ((self wand-image) &key) (ecase (direction self) @@ -47,7 +46,7 @@ "Image file ~a not found initializing wand" (file-path$ self)) (assert (not (mgk-wand self))) ;; make sure not leaking (setf (mgk-wand self) (path-to-wand (file-path$ self))) - ;(mgk-wand-dump (mgk-wand self) (file-path$ self)) + ;;(mgk-wand-dump (mgk-wand self) (file-path$ self)) (when (and (mgk-wand self) (not (image-size self))) (setf (image-size self) (cons (magick-get-image-width (mgk-wand self)) @@ -79,9 +78,11 @@ (fgn-alloc :unsigned-long 1 :ignore)) (defun wand-image-size (wand) - (magick-get-size wand *mgk-columns* *mgk-rows*) + (magick-get-size wand + *mgk-columns* + *mgk-rows*) (cons (ff-elt *mgk-columns* :unsigned-long 0) - (ff-elt *mgk-rows* :unsigned-long 0))) + (ff-elt *mgk-rows* :unsigned-long 0))) (defun wand-get-image-pixels (wand &optional (first-col 0) (first-row 0) @@ -99,15 +100,10 @@ (rows (- last-row first-row)) (pixels (fgn-alloc :unsigned-char (* 3 columns rows) :wand-image))) - ;(print (list "wand-get-image-pixels got" wand (* 3 columns rows) pixels)) - (cells:trc nil "image format" wand (magick-get-image-format wand)) + ;;(print (list "wand-get-image-pixels got" wand (* 3 columns rows) pixels)) ;; frgo: debug ... + ;;(cells:trc "image format" wand (magick-get-image-format wand)) ;; frgo:debug... (magick-get-image-pixels wand first-col first-row columns rows "RGB" 0 pixels ) - #+testing (progn - (incf testn) - (print `(writeimage ,(magick-write-image wand (format nil "C:\\TEST~a.JPG" testn)))) - (print `(writeimage ,(magick-write-image wand (format nil "C:\\TEST~a.GIF" testn)))) - #+not (print `(writeimage ,(magick-write-image wand "C:\\TEST.BMP")))) - + ;;(print `(writeimage ,(magick-write-image wand "/tmp/wand-image-test.jpg"))) #+jesfoolinaround(loop for row below 16 do (loop for col below 16 by 1 for offset = (+ (* row columns 3) (* col 3))

1 0

[cello-cvs] CVS cello/cl-magick
by fgoenninger 28 Aug '06

28 Aug '06

Update of /project/cello/cvsroot/cello/cl-magick In directory clnet:/tmp/cvs-serv21072 Modified Files: wand-texture.lisp Log Message: Changed: Added some (now inactive) print statements for debugging only. --- /project/cello/cvsroot/cello/cl-magick/wand-texture.lisp 2006/08/23 20:20:27 1.5 +++ /project/cello/cvsroot/cello/cl-magick/wand-texture.lisp 2006/08/28 18:41:19 1.6 @@ -42,14 +42,14 @@ (grow-sz (cons (expt 2 (ceiling (log (car (image-size self)) 2))) (expt 2 (ceiling (log (cdr (image-size self)) 2))))) (best-fit-sz (best-fit-cons trunc-sz (image-size self) grow-sz))) - #+shh (print `(texture-name> gennning texture ,self)) + ;;(print `(texture-name> gennning texture ,self)) ;; frgo: debug... (unless (equal (image-size self) best-fit-sz) - #+shhh (print `(texture-name> tex-refit ,(image-size self) to ,best-fit-sz)) + ;;(print `(texture-name> tex-refit ,(image-size self) to ,best-fit-sz)) ;; frgo: debug... (magick-scale-image (mgk-wand self) (car best-fit-sz) (cdr best-fit-sz)) ;;; gaussian-filter 0) (setf (image-size self) best-fit-sz)) - #+shhh (print `(texture-name> new image size , self ,(image-size self))) + ;; (print `(texture-name> new image size , self ,(image-size self))) ;; frgo: debug... (let ((tx (wand-image-to-texture self))) (if (plusp tx) (setf (texture-name self) tx) @@ -57,19 +57,20 @@ (defun wand-texture-activate (wand) - ;(print `(wand-texture-activate ,(texture-name wand))) + ;;(print `(wand-texture-activate ,(texture-name wand))) (ogl-tex-activate (texture-name wand))) (defparameter *textures-1* (fgn-alloc 'kt-opengl::gluint 1 :ignore)) + (defun wand-image-to-texture (self) (let ((tx (ogl-texture-gen) #+not (progn (gl-gen-textures 1 *textures-1*) (ff-elt *textures-1* gluint 0))) (pixels (wand-get-image-pixels (mgk-wand self) 0 0 (car (image-size self)) (cdr (image-size self))))) - ;; (assert (not *ogl-listing-p*)) + ;;(assert (not *ogl-listing-p*)) (assert (plusp tx)) - ;; (cells:trc "!!!!wand-image-to-texture genning new tx: ~a" tx) + ;;(cells:trc "!!!!wand-image-to-texture genning new tx: ~a" tx) ;; frgo: debug... (gl-bind-texture gl_texture_2d tx) (progn ;; useless?? @@ -86,7 +87,7 @@ (gl-tex-image2d gl_texture_2d 0 3 (car (image-size self)) (cdr (image-size self)) 0 gl_rgb gl_unsigned_byte pixels) (kt-opengl::glec :tex-image) - ;;(print `(wand-image-to-texture loaded texture sized ,(image-size self))) + (print `(wand-image-to-texture loaded texture sized ,(image-size self))) ;; frgo: debug... (fgn-free pixels) tx))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

cello-cvs August 2006