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

[cello-cvs] CVS cello/kt-opengl
by ktilton 11 Apr '08

11 Apr '08

Update of /project/cello/cvsroot/cello/kt-opengl In directory clnet:/tmp/cvs-serv7403/kt-opengl Modified Files: colors.lisp defpackage.lisp kt-opengl-config.lisp kt-opengl.lisp kt-opengl.lpr ogl-macros.lisp Log Message: --- /project/cello/cvsroot/cello/kt-opengl/colors.lisp 2007/02/02 20:11:17 1.9 +++ /project/cello/cvsroot/cello/kt-opengl/colors.lisp 2008/04/11 09:23:07 1.10 @@ -20,7 +20,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. ;;; -;;; $Id: colors.lisp,v 1.9 2007/02/02 20:11:17 ktilton Exp $ +;;; $Id: colors.lisp,v 1.10 2008/04/11 09:23:07 ktilton Exp $ (in-package #:kt-opengl) @@ -251,6 +251,7 @@ (define-ogl-rgba-color +orange+ 192 192 192 255) (define-ogl-rgba-color +saddle-brown+ 139 69 19 255) +(define-ogl-rgba-color +brown+ 139 69 19 255) ;;; PANTONE colors as defined by graphics design s/w Art Director's Toolkit V.5 --- /project/cello/cvsroot/cello/kt-opengl/defpackage.lisp 2007/02/02 20:11:18 1.3 +++ /project/cello/cvsroot/cello/kt-opengl/defpackage.lisp 2008/04/11 09:23:07 1.4 @@ -20,13 +20,13 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Id: defpackage.lisp,v 1.3 2007/02/02 20:11:18 ktilton Exp $ +;;; $Id: defpackage.lisp,v 1.4 2008/04/11 09:23:07 ktilton Exp $ (pushnew :kt-opengl *features*) (defpackage #:kt-opengl (:nicknames #:ogl) - (:use #:common-lisp #:cffi #:ffx) + (:use #:common-lisp #:cffi #:ffx #:utils-kt) (:export #:kt-opengl-init @@ -78,6 +78,7 @@ #:v3f-y #:v3f-z #:mkv3f + #:mk-rgba #:v3d #:make-v3d --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl-config.lisp 2007/02/02 20:11:19 1.2 +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl-config.lisp 2008/04/11 09:23:07 1.3 @@ -23,8 +23,8 @@ (in-package :kt-opengl) (define-foreign-library OpenGL - (:windows (:or "/windows/system32/opengl32.dll")) + (:windows (:or "opengl32.dll")) (:darwin (:or (:framework "OpenGL")))) (define-foreign-library GLU - (:windows (:or "/windows/system32/glu32.dll"))) + (:windows (:or "glu32.dll"))) --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lisp 2007/02/02 20:11:19 1.12 +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lisp 2008/04/11 09:23:07 1.13 @@ -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.12 2007/02/02 20:11:19 ktilton Exp $ +;;; $Id: kt-opengl.lisp,v 1.13 2008/04/11 09:23:07 ktilton Exp $ (pushnew :kt-opengl *features*) @@ -50,6 +50,7 @@ when (zerop ec) do (loop-finish) do (cells::trc "kt-opengl-init sees error" ec))) +;; this breaks build of distro since that builds dll path differently (eval-when (:load-toplevel :execute) (kt-opengl-init)) --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lpr 2007/02/02 20:11:19 1.9 +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lpr 2008/04/11 09:23:07 1.10 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jan 29, 2007 18:02)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cello/cvsroot/cello/kt-opengl/ogl-macros.lisp 2007/02/02 20:11:19 1.11 +++ /project/cello/cvsroot/cello/kt-opengl/ogl-macros.lisp 2008/04/11 09:23:07 1.12 @@ -129,6 +129,7 @@ (gl-translatef (- ,dx)(- ,dy)(- ,dz)))))) (defun glec (&optional (id :anon) announce-success) + #-its-alive! (if (and (boundp '*gl-begun*) *gl-begun*) (progn (cells:trc nil "not checking error inside gl.begin" id)) (let ((e (glgeterror))) @@ -141,7 +142,7 @@ (progn (setf *gl-stop* t) (format t "~&~%OGL error ~a at ID ~a" e id) - (break "OGL error ~a at ID ~a" e id) + ;(break "OGL error ~a at ID ~a" e id) )) #+sigh (print `("OGL error ~a at ID ~a" ,e ,id)))))))

1 0

[cello-cvs] CVS cello/cl-openal
by ktilton 11 Apr '08

11 Apr '08

Update of /project/cello/cvsroot/cello/cl-openal In directory clnet:/tmp/cvs-serv7403/cl-openal Modified Files: cl-openal-init.lisp cl-openal.lisp Log Message: --- /project/cello/cvsroot/cello/cl-openal/cl-openal-init.lisp 2007/09/07 18:42:15 1.10 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal-init.lisp 2008/04/11 09:23:06 1.11 @@ -31,7 +31,7 @@ (cl-openal-init t) (defun cl-openal-init (&optional force) - ;;(return-from cl-openal-init nil) + (return-from cl-openal-init nil) (when (and *openal-initialized-p* (not force)) (return-from cl-openal-init t)) --- /project/cello/cvsroot/cello/cl-openal/cl-openal.lisp 2007/02/02 20:11:14 1.6 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal.lisp 2008/04/11 09:23:06 1.7 @@ -22,7 +22,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Id: cl-openal.lisp,v 1.6 2007/02/02 20:11:14 ktilton Exp $ +;;; $Id: cl-openal.lisp,v 1.7 2008/04/11 09:23:06 ktilton Exp $ (pushnew :cl-openal *features*) @@ -45,11 +45,11 @@ (define-foreign-library OpenAL (:darwin (:framework "OpenAL")) - (:windows (:or "/windows/system32/openal32.dll"))) + (:windows (:or "openal32.dll"))) ;; OpenAL 1.0: No separate ALUT for OS X (define-foreign-library ALut - (:windows (:or "/windows/system32/alut.dll"))) + (:windows (:or "alut.dll"))) (defparameter *audio-files* (make-pathname

1 0

[cello-cvs] CVS cello/cl-magick
by ktilton 11 Apr '08

11 Apr '08

Update of /project/cello/cvsroot/cello/cl-magick In directory clnet:/tmp/cvs-serv7403/cl-magick Modified Files: cl-magick.lisp cl-magick.lpr mgk-utils.lisp wand-image.lisp wand-texture.lisp Log Message: --- /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2007/02/02 20:11:09 1.15 +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2008/04/11 09:23:01 1.16 @@ -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.15 2007/02/02 20:11:09 ktilton Exp $ +;;; $Id: cl-magick.lisp,v 1.16 2008/04/11 09:23:01 ktilton Exp $ (defpackage :cl-magick @@ -71,11 +71,14 @@ (defparameter *mgk-version* (fgn-alloc :unsigned-long 1)) (cffi:define-foreign-library Magick - (:darwin #-(and)(:framework "GraphicsMagick") - "libGraphicsMagick.dylib" - "libGraphicsMagickWand.dylib") - (:windows (:or #+not "C:\\Program Files\\ImageMagick-6.2.7-Q8\\CORE_RL_wand_.dll" - "C:\\Program Files\\GraphicsMagick-1.1.7-Q8\\CORE_RL_wand_.dll"))) +;;; patches welcomes on this next bit +;;; (:darwin #-(and)(:framework "GraphicsMagick") +;;; "libGraphicsMagick.dylib" +;;; "libGraphicsMagickWand.dylib") + (:windows (:or "CORE_RL_wand_.dll" ))) + +#+test +(probe-file (cells:exe-dll "CORE_RL_wand_")) (cffi:define-foreign-library Wand (:darwin (:or "/usr/local/lib/libWand.dylib"))) @@ -85,6 +88,7 @@ #+macosx (cffi:use-foreign-library Wand) + (cffi:use-foreign-library Magick) ;------------------------------------------------------------------- @@ -108,6 +112,9 @@ do (wand-release (cdr wand))) (setf (wands-loaded) nil)) +#+doit +(wands-clear) + (defun wand-ensure-typed (wand-type path &rest iargs) (when path (cl-magick-init) --- /project/cello/cvsroot/cello/cl-magick/cl-magick.lpr 2007/02/02 20:11:09 1.10 +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lpr 2008/04/11 09:23:02 1.11 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Jan 29, 2007 18:02)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Mar 7, 2007 14:53)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cello/cvsroot/cello/cl-magick/mgk-utils.lisp 2007/02/02 20:11:09 1.3 +++ /project/cello/cvsroot/cello/cl-magick/mgk-utils.lisp 2008/04/11 09:23:02 1.4 @@ -66,8 +66,9 @@ ;;; gaussian-filter ;; /// any faster? mode doesn't matter, about to stomp pix ;;; 0)) - (if (zerop (magick-set-image-pixels wand 0 0 - width height "RGB" short-pixel pixels)) + (if (zerop ;; the GM doc seems in error when it says zero is success + (magick-set-image-pixels wand 0 0 + width height "RGB" short-pixel pixels)) (error "MagickSetImagePixels failed: ~a" wand) (magick-flip-image wand) ;; /// necessary? ) --- /project/cello/cvsroot/cello/cl-magick/wand-image.lisp 2007/02/02 20:11:09 1.10 +++ /project/cello/cvsroot/cello/cl-magick/wand-image.lisp 2008/04/11 09:23:02 1.11 @@ -30,8 +30,7 @@ (mgk-wand :initarg :mgk-wand :initform nil :accessor mgk-wand) (image-size :initarg :image-size :initform nil :accessor image-size) (storage :initarg :storage :initform GL_RGB :accessor storage) - (tilep :initarg :tilep :initform t :accessor tilep) - )) + (tilep :initarg :tilep :initform t :accessor tilep))) (defmethod initialize-instance :after ((self wand-image) &key) (ecase (wand-direction self) @@ -40,11 +39,11 @@ (assert (image-size self)) (setf (mgk-wand self) (new-magick-wand)) (destructuring-bind (columns . rows) (image-size self) - (assert (zerop (magick-set-image-pixels - (setf (mgk-wand self) (new-magick-wand)) - 0 0 columns rows "CRGB" 3 (pixels self))))) - (magick-set-image-type (mgk-wand self) 3) - )) + (progn ;; assert (zerop ... well, the doc says zero=sucess, but not the GM.c code (or flop writes) + (magick-set-image-pixels + (setf (mgk-wand self) (new-magick-wand)) + 0 0 columns rows "CRGB" 3 (pixels self)))) + (magick-set-image-type (mgk-wand self) 3))) (:input (assert (probe-file (image-path self)) () "Image file ~a not found initializing wand" (image-path self)) @@ -62,8 +61,7 @@ (when (mgk-wand wand) ;(print (list "destroying magick wand" wand)) ;(describe wand) - (destroy-magick-wand (mgk-wand wand)) - )) + (destroy-magick-wand (mgk-wand wand)))) (defun path-to-wand (path) (let ((wand (new-magick-wand)) @@ -71,10 +69,9 @@ (assert (probe-file p)) (let ((stat (magick-read-image wand p))) (if (zerop stat) - (format t "~&magick-read-image failed on ~a" p) ;; and return NIL ;; kt 2006-11-21 - (progn - #+shhh (format t "~&magick-read-OK ~a" p) - wand))))) + (format t "~&magick-read-image failed on ~a" p) + (format nil "~&magick-read-OK ~a" p)) + wand))) (defun wand-get-image-pixels (self &optional (first-col 0) (first-row 0) (last-col (magick-get-image-width (mgk-wand self))) @@ -113,10 +110,13 @@ (unless (block detect-converted (loop for pixel-col fixnum below columns for pixel-offset fixnum = (the fixnum (+ 3 (* pixel-col bytes-per-pixel))) - when (/= 255 (eltuc pixels (the fixnum pixel-offset))) - do (cells:trc "image alpha already converted. I see non-255" (eltuc pixels (the fixnum pixel-offset)) :at-col pixel-col) + when (> 96 ;; rough guess at how to detect: can't always get perfect alpha w eraser: /= 255 + (eltuc pixels (the fixnum pixel-offset))) + do (cells:trc "image alpha already converted. I see non-255" + (image-path self) + (eltuc pixels (the fixnum pixel-offset)) :at-col pixel-col) (return-from detect-converted t))) - (cells:trc "converting alpha channel!!!!!!!!!!!!!!!!!!!" self) + ;;(cells:trc "converting alpha channel!!!!!!!!!!!!!!!!!!!" self) (loop with pix1 for row fixnum below rows @@ -125,7 +125,7 @@ do (let ((alpha (eltuc pixels pixel-offset))) (unless pix1 (when (zerop alpha) - (cells::trcx binogo-pix1 pixel-col row) + ;;(cells::trcx binogo-pix1 pixel-col row) (setf pix1 (cons pixel-col row)))) (setf (eltuc pixels (the fixnum pixel-offset)) (- 255 alpha)))) ;;when (zerop (eltuc pixels (the fixnum pixel-offset))) @@ -135,7 +135,7 @@ ; in place... ; (magick-set-image-pixels wand 0 0 columns rows storage$ 0 pixels) - (let ((reduction (max 1 (sqrt (/ (* columns rows) 200000))))) + #+no(let ((reduction (max 1 (sqrt (/ (* columns rows) 200000))))) (unless (= reduction 1) (cells:trc "reduction factor!!!!!!!" reduction) (setf columns (round columns reduction) rows (round rows reduction)) @@ -148,9 +148,7 @@ (let ((cw (clone-magick-wand wand))) (magick-set-image-type cw (magick-get-image-type wand)) (magick-get-image-pixels wand 0 0 columns rows storage$ 0 pixels ) ;; get resized pixels - (let ((e (magick-set-image-pixels cw 0 0 columns rows storage$ 0 pixels))) - (unless (zerop e) - (cells:trc "Error setting pixels!!!!!!!!" e))) + (magick-set-image-pixels cw 0 0 columns rows storage$ 0 pixels) (magick-flop-image cw) (wand-images-write cw (merge-pathnames (conc$ (pathname-name (image-path self)) "-flop") --- /project/cello/cvsroot/cello/cl-magick/wand-texture.lisp 2007/02/02 20:11:10 1.9 +++ /project/cello/cvsroot/cello/cl-magick/wand-texture.lisp 2008/04/11 09:23:02 1.10 @@ -37,33 +37,33 @@ (defmethod texture-name :around ((self wand-texture)) (or (call-next-method) - (let ((tx (wand-image-to-texture self))) - (if (plusp tx) - (setf (texture-name self) tx) - (break "bad tx name ~a for ~a" tx self))))) - -;;; -;;; this next stuff converts image to 2^n dimensions and may still be necessary -;;; on older graphics cards. /// test for this on old or lame PCs -;;; -;;; (let* ((trunc-sz (cons (expt 2 (floor (log (car (image-size self)) 2))) -;;; (expt 2 (floor (log (cdr (image-size self)) 2))))) -;;; (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))) -;;; ;;(print `(texture-name> gennning texture ,self)) ;; frgo: debug... -;;; -;;; (unless t ;; (equal (image-size self) best-fit-sz) -;;; ;(print `(texture-name> tex-refit ,(image-size self) to ,best-fit-sz)) -;;; (magick-scale-image (mgk-wand self) (car best-fit-sz) (cdr best-fit-sz)) -;;; ;;; gaussian-filter 0) -;;; (setf (image-size self) best-fit-sz)) -;;; -;;; ;;(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) -;;; (break "bad tx name ~a for ~a" tx self)))))) + ;;; (let ((tx (wand-image-to-texture self))) + ;;; (if (plusp tx) + ;;; (setf (texture-name self) tx) + ;;; (break "bad tx name ~a for ~a" tx self))))) + + ;;; + ;;; this next stuff converts image to 2^n dimensions and may still be necessary + ;;; on older graphics cards. /// test for this on old or lame PCs + ;;; + (let* ((trunc-sz (cons (expt 2 (floor (log (car (image-size self)) 2))) + (expt 2 (floor (log (cdr (image-size self)) 2))))) + (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))) + ;;(print `(texture-name> gennning texture ,self)) ;; frgo: debug... + + (unless (equal (image-size self) best-fit-sz) + ;(print `(texture-name> tex-refit ,(image-size self) to ,best-fit-sz)) + (magick-scale-image (mgk-wand self) (car best-fit-sz) (cdr best-fit-sz)) + ;;; gaussian-filter 0) + (setf (image-size self) best-fit-sz)) + + ;;(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) + (break "bad tx name ~a for ~a" tx self)))))) (defun wand-texture-activate (wand) @@ -90,7 +90,8 @@ (gl-pixel-storei gl_pack_alignment 1 ) (gl-pixel-storei gl_unpack_alignment 1 ) - + (cells::trc nil "wand-image-to-texture> tex-iage2d-ing" (image-path self)(image-size self)) + (kt-opengl::glec :tex-image-before) (gl-tex-image2d gl_texture_2d 0 gl_rgba (car (image-size self)) (cdr (image-size self)) 0 (storage self) gl_unsigned_byte pixels) (kt-opengl::glec :tex-image)

1 0

[cello-cvs] CVS cello/cl-ftgl
by ktilton 11 Apr '08

11 Apr '08

Update of /project/cello/cvsroot/cello/cl-ftgl In directory clnet:/tmp/cvs-serv7403/cl-ftgl Modified Files: cl-ftgl.lisp cl-ftgl.lpr Log Message: --- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2007/02/02 20:11:02 1.17 +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2008/04/11 09:22:58 1.18 @@ -20,14 +20,14 @@ ;;; 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.17 2007/02/02 20:11:02 ktilton Exp $ +;;; $Header: /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp,v 1.18 2008/04/11 09:22:58 ktilton Exp $ (eval-when (:compile-toplevel :load-toplevel) (pushnew :cl-ftgl *features*)) (defpackage #:cl-ftgl (:nicknames #:ftgl) - (:use #:common-lisp #:cffi #:kt-opengl) + (:use #:common-lisp #:cffi #:kt-opengl #:utils-kt #:cells #:cl-freetype) (:export #:ftgl #:ftgl-pixmap #:ftgl-texture @@ -40,6 +40,7 @@ #:ftgl-get-ascender #:ftgl-get-descender #:ftgl-height + #:ftgl-filetype #:ftgl-make #:cl-ftgl-init #:cl-ftgl-reset @@ -47,6 +48,7 @@ #:ftgl-render #:ftgl-font-ensure #:ftgl-format + #:ftgl-ft-face #:*font-directory-path* #:*gui-style-default-face* #:*gui-style-button-face* @@ -57,73 +59,87 @@ ;;; NOTE: Must build the ftgl-int/FTGLFromC.cpp glue library. (define-foreign-library FTGL (:darwin "libfgc.dylib") - (:windows (:or "/0dev/user/dynlib/ftgl_dynamic_MTD_d.dll"))) + (:windows (:or "ftgl_dynamic_MTD_d.dll"))) + +#+test +(inspect (cffi::get-foreign-library 'FTGL)) + +#+test +(probe-file (ukt:exe-dll "ftgl_dynamic_MTD_d")) ;;(use-foreign-library FTGL) - frgo: This leads to problems on OS X !!! ;; -> Use function cl-ftgl-init ! (defparameter *gui-style-default-face* - #-cffi-features:darwin 'sylfaen + #-cffi-features:darwin "STIXGeneral" ;; "Sylfaen" #+cffi-features:darwin "Helvetica") (defparameter *gui-style-button-face* - #-cffi-features:darwin 'sylfaen + #-cffi-features:darwin "STIXGeneral" ;; "Sylfaen" #+cffi-features:darwin "Helvetica") (defparameter *ftgl-loaded-p* nil) (defparameter *ftgl-fonts-loaded* nil) (defparameter *ftgl-ogl* nil) -(defparameter *ftgl-font-pathnames-list* - - #+cffi-features:windows - (list - (make-pathname - :directory - '(:absolute "Windows" "fonts"))) +(defparameter *ftgl-font-dirs* nil) - #+cffi-features:darwin - (list - (make-pathname - :directory +(defun ftgl-font-directories () + (or *ftgl-font-dirs* + (setf *ftgl-font-dirs* + #+cffi-features:windows + (list (font-path) + (make-pathname + :directory + '(:absolute "Windows" "fonts"))) + #+cffi-features:darwin + (list + (make-pathname + :directory '(:absolute "System" "Library" "Fonts")) - (make-pathname - :directory + (make-pathname + :directory '(:absolute "Library" "Fonts")) - (make-pathname - :directory - '(:relative "~" "Library" "Fonts"))) - - #+(and cffi-features:unix (not cffi-features:darwin)) - (list - (make-pathname - :directory - '(:absolute "usr" "share" "truetype"))) - ) + (make-pathname + :directory + '(:relative "~" "Library" "Fonts"))) + + #+(and cffi-features:unix (not cffi-features:darwin)) + (list + (make-pathname + :directory + '(:absolute "usr" "share" "truetype")))))) (defparameter *ftgl-font-types-list* ;; list of font types - ;; (font filename endings) + ;; (font filename endings) #+cffi-features:darwin '("dfont" "ttf") #+(or cffi-features:windows (and cffi-features:unix (not cffi-features:darwin))) - '("ttf") -) - + '("ttf" "otf")) (defun find-font-file (font) - (loop named pn-loop for pathname in *ftgl-font-pathnames-list* - do - (loop for ending in *ftgl-font-types-list* - do - (let ((pn (merge-pathnames (make-pathname - :name (string (ftgl-face font)) - :type ending) - pathname))) - (if (probe-file pn) - (progn - ;;(format t "~%*** FIND-FONT-FILE: Result = ~A~%" pn) - (return-from pn-loop pn))))))) + (trc nil "find.font.file> seeks" (ftgl-face font) :n (ftgl-font-directories)) + (or + (loop for dir in (ftgl-font-directories) + thereis (loop for ending in *ftgl-font-types-list* + thereis (probe-file (merge-pathnames (make-pathname + :name (string (ftgl-face font)) + :type ending) + dir)))) + (loop initially (trc "find.font.file cant find any of" + (loop for ending in *ftgl-font-types-list* + collecting (make-pathname + :name (string (ftgl-face font)) + :type ending))) + for dir in (ftgl-font-directories) do + (loop for f in (directory dir) + when (and (string-equal (pathname-type f) "TTF") + (string-equal (pathname-name f) (string (ftgl-face font)))) + do (trc "...does see" (namestring f)))))) + +#+test +(probe-file "C:\\0Algebra\\TYExtender\\font\\Sylfaen.ttf") (defun ftgl-format (font control-string &rest args) (ftgl-render font (apply 'format nil control-string args))) @@ -185,8 +201,15 @@ (defun cl-ftgl-reset () #-(or mcl macosx) (setq *ftgl-loaded-p* nil) + #+noway (loop for (nil . font) in *ftgl-fonts-loaded* + do (fgc-free (ftgl-ifont font))) (setq *ftgl-fonts-loaded* nil)) +#+test +(progn + (mgk:wands-clear) + (cl-ftgl-reset)) + (defmacro dbgftgl (tag &body body) (declare (ignorable tag)) `(progn @@ -204,33 +227,40 @@ #+test (progn (cl-ftgl-init) - (let ((sylfaen (ftgl-font-ensure :texture |ArialHB| 24 96))) + (let ((sylfaen (ftgl-font-ensure :texture '|ArialHB| 24 96))) (print (list "ArialHB ascender" (ftgl-get-ascender sylfaen))) (print (list "ArialHB descender" (ftgl-get-descender sylfaen))) (print (list "ArialHB hello world length" (ftgl-string-length sylfaen "Hello world"))) (print (list "ArialHB disp font" (ftgl-get-display-font sylfaen))) )) + (defun cl-ftgl-init () + (initialize-ft) (unless *ftgl-loaded-p* (assert (setq *ftgl-loaded-p* (use-foreign-library FTGL))) (format *debug-io* "~%*** CL-FTGL-INIT: Loaded: ~S~%" *ftgl-loaded-p*))) +#+test +(loop for (fspec . f) in *ftgl-fonts-loaded* + do (print (list fspec f))) (defun ftgl-font-ensure (type face size target-res &optional (depth 0)) (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 )) + #+shhh (if match + (progn (cells::trc "ftgl-font-ensure finds match" fspec (ftgl-ifont match))) + (cells::trc "ftgl-font-ensure NO match" fspec :in #+shhh (loop for (fspec nil) in *ftgl-fonts-loaded* + collecting 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)) + ;; (cells::trc "ftgl-font-ensure allocating!!!!!!!!!!! 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)) + (funcall (ecase type (:bitmap 'make-ftgl-bitmap) (:pixmap 'make-ftgl-pixmap) @@ -252,6 +282,8 @@ face size target-res depth descender ascender (widths (make-array 256 :initial-element nil)) + ft-face + filetype ft-metrics (ifont nil)) @@ -303,22 +335,36 @@ (ff:unload-foreign-library dll) (cl-ftgl-reset)))) +#+test +(dolist (dll (ff:list-all-foreign-libraries)) + (when t ;(search "free" (pathname-name dll) :test 'string-equal) + (print `(foreign library ,dll)))) + #+doit (xftgl) (defun ftgl-get-ascender (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)))))) + (or (ftgl-ascender font) + (setf (ftgl-ascender font) + (eko (nil "ftgl.get.ascender" font) + (let ((mf (ftgl-get-metrics-font font))) ; also loads face + (if (string-equal (ftgl-face font) "math2___") + (ftgl-size font) + #+yeahyeah (round (ft:ft-glyphslotrec/metrics/hori-bearing/y + (ft:load-glyph (ftgl-ft-face font) 0 3)) 96) + (fgc-ascender mf)))))))) (defun ftgl-get-descender (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)))))) + (eko (nil "ftgl.get.descender" font) + (if (string-equal (ftgl-face font) "math2___") + (round (ftgl-size font) -2) + (fgc-descender (ftgl-get-metrics-font font)))))))) (defun ftgl-height (f) (cells:trc nil "ftgl-height" (ftgl-ifont f)) @@ -335,8 +381,9 @@ ;; (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)) + (cells:trc "ftgl-get-display-font" (ftgl-face font) (ftgl-size font)(ftgl-ifont font)) + (when *ogl-listing-p* + (cells::c-break "bad time #1 for sizing? ~a ~a" *ogl-listing-p* (cons (ftgl-face font)(ftgl-size font))(ftgl-ifont font))) (setf (ftgl-ready font) t) (typecase font (ftgl-extruded @@ -346,7 +393,7 @@ (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))) + #+fails (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) @@ -357,16 +404,32 @@ (setf (ftgl-ifont font) (ftgl-font-make font)))) (defun ftgl-font-make (font) - (let ((path (find-font-file font))) - (if path - (let* ((fpath (namestring path)) - (f (fgc-font-make font fpath))) - (if f - (progn - (fgc-set-face-size f (ftgl-size font) (ftgl-target-res font)) - f) - (error "cannot load ~a font ~a" (type-of font) fpath))) - (error "Font not found: ~a" path)))) + (eko (nil "made cpp FTGL font ~a" (ftgl-face font)(ftgl-size font)) + (bif (path (find-font-file font)) + (let ((fpath (namestring path))) + (bif (f (fgc-font-make font fpath)) + (progn + (prog1 + (setf (ftgl-ft-face font) (ft:get-new-face (namestring path))) + ;(trc "making!!!!!!!!!!!! afce!!!!!!" (ftgl-face font)) + (assert (ftgl-ft-face font))) + (ft:set-char-size (ftgl-ft-face font) (ft:to-ft (ftgl-size font)) (ftgl-target-res font)) + #+shhh (loop with size = (ft:ft-facerec/size (ftgl-ft-face font)) + for (k m) on (list :x-ppem (ft:ft-sizerec/metrics/x-ppem size) + :y-ppem (ft:ft-sizerec/metrics/y-ppem size) + :x-scale (ft:ft-sizerec/metrics/x-scale size) + :y-scale (ft:ft-sizerec/metrics/y-scale size) + :ascender (ft:ft-sizerec/metrics/ascender size) + :descender (ft:ft-sizerec/metrics/descender size) + :height (ft:ft-sizerec/metrics/height size) + :max-advance (ft:ft-sizerec/metrics/max-advance size)) by #'cddr + do (print (list k (ft:from-ft m)))) + + (setf (ftgl-filetype font) (intern (up$ (pathname-type path)) :keyword)) + (fgc-set-face-size f (ftgl-size font) (ftgl-target-res font)) + f) + (error "cannot load ~a font ~a" (type-of font) fpath))) + (error "Font not found: ~a" path)))) (defmethod ftgl-render (font s) (assert font) @@ -374,11 +437,11 @@ (dbgfont font :ftgl-render) (dbgftgl :ftgl-render (when font - (let ((df (ftgl-get-display-font font))) - (cells: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)))))) + (fgc-render (ftgl-get-metrics-font font) s)))) + +(defmethod ftgl-render :before ((font ftgl-extruded) s) + (declare (ignorable s)) + (ftgl-get-display-font font)) (defmethod ftgl-render :before ((font ftgl-texture) s) (declare (ignorable s)) @@ -400,7 +463,7 @@ (fgc-bitmap-make fpath)) (defmethod fgc-font-make ((font ftgl-texture) fpath) - (format *debug-io* "~%*** FGC-FONT-MAKE: fpath = ~A~%" fpath) + (format *debug-io* "~%*** FGC-FONT-MAKE: texture fpath = ~A~%" fpath) (fgc-texture-make fpath)) (defmethod fgc-font-make ((font ftgl-extruded) fpath) --- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2007/02/02 20:11:03 1.11 +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2008/04/11 09:22:58 1.12 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.1 [Windows] (Jan 2, 2008 9:44)"; cg: "1.103.2.10"; -*- (in-package :cg-user) @@ -17,64 +17,72 @@ :main-form nil :compilation-unit t :verbose nil - :runtime-modules '(:cg-dde-utils :cg.base :cg.bitmap-pane - :cg.bitmap-pane.clipboard :cg.bitmap-stream - :cg.button :cg.caret :cg.check-box :cg.choice-list - :cg.choose-printer :cg.clipboard - :cg.clipboard-stack :cg.clipboard.pixmap - :cg.color-dialog :cg.combo-box :cg.common-control - :cg.comtab :cg.cursor-pixmap :cg.curve - :cg.dialog-item :cg.directory-dialog - :cg.directory-dialog-os :cg.drag-and-drop - :cg.drag-and-drop-image :cg.drawable - :cg.drawable.clipboard :cg.dropping-outline - :cg.edit-in-place :cg.editable-text - :cg.file-dialog :cg.fill-texture - :cg.find-string-dialog :cg.font-dialog - :cg.gesture-emulation :cg.get-pixmap - :cg.get-position :cg.graphics-context - :cg.grid-widget :cg.grid-widget.drag-and-drop - :cg.group-box :cg.header-control :cg.hotspot - :cg.html-dialog :cg.html-widget :cg.icon - :cg.icon-pixmap :cg.ie :cg.item-list - :cg.keyboard-shortcuts :cg.lamp :cg.lettered-menu - :cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget - :cg.list-view :cg.mci :cg.menu :cg.menu.tooltip - :cg.message-dialog :cg.multi-line-editable-text - :cg.multi-line-lisp-text :cg.multi-picture-button - :cg.multi-picture-button.drag-and-drop - :cg.multi-picture-button.tooltip :cg.ocx - :cg.os-widget :cg.os-window :cg.outline - :cg.outline.drag-and-drop - :cg.outline.edit-in-place :cg.palette - :cg.paren-matching :cg.picture-widget - :cg.picture-widget.palette :cg.pixmap - :cg.pixmap-widget :cg.pixmap.file-io - :cg.pixmap.printing :cg.pixmap.rotate :cg.printing - :cg.progress-indicator :cg.project-window - :cg.property :cg.radio-button :cg.rich-edit - :cg.rich-edit-pane :cg.rich-edit-pane.clipboard - :cg.rich-edit-pane.printing :cg.sample-file-menu - :cg.scaling-stream :cg.scroll-bar - :cg.scroll-bar-mixin :cg.selected-object - :cg.shortcut-menu :cg.static-text :cg.status-bar - :cg.string-dialog :cg.tab-control - :cg.template-string :cg.text-edit-pane - :cg.text-edit-pane.file-io :cg.text-edit-pane.mark - :cg.text-or-combo :cg.text-widget :cg.timer - :cg.toggling-widget :cg.toolbar :cg.tooltip - :cg.trackbar :cg.tray :cg.up-down-control - :cg.utility-dialog :cg.web-browser - :cg.web-browser.dde :cg.wrap-string - :cg.yes-no-list :cg.yes-no-string :dde) + :runtime-modules (list :cg-dde-utils :cg.base :cg.bitmap-pane + :cg.bitmap-pane.clipboard :cg.bitmap-stream + :cg.button :cg.caret :cg.check-box + :cg.choice-list :cg.choose-printer + :cg.clipboard :cg.clipboard-stack + :cg.clipboard.pixmap :cg.color-dialog + :cg.combo-box :cg.common-control :cg.comtab + :cg.cursor-pixmap :cg.curve :cg.dialog-item + :cg.directory-dialog :cg.directory-dialog-os + :cg.drag-and-drop :cg.drag-and-drop-image + :cg.drawable :cg.drawable.clipboard + :cg.dropping-outline :cg.edit-in-place + :cg.editable-text :cg.file-dialog + :cg.fill-texture :cg.find-string-dialog + :cg.font-dialog :cg.gesture-emulation + :cg.get-pixmap :cg.get-position + :cg.graphics-context :cg.grid-widget + :cg.grid-widget.drag-and-drop :cg.group-box + :cg.header-control :cg.hotspot :cg.html-dialog + :cg.html-widget :cg.icon :cg.icon-pixmap + :cg.ie :cg.item-list :cg.keyboard-shortcuts + :cg.lamp :cg.lettered-menu :cg.lisp-edit-pane + :cg.lisp-text :cg.lisp-widget :cg.list-view + :cg.mci :cg.menu :cg.menu.tooltip + :cg.message-dialog + :cg.multi-line-editable-text + :cg.multi-line-lisp-text + :cg.multi-picture-button + :cg.multi-picture-button.drag-and-drop + :cg.multi-picture-button.tooltip :cg.ocx + :cg.os-widget :cg.os-window :cg.outline + :cg.outline.drag-and-drop + :cg.outline.edit-in-place :cg.palette + :cg.paren-matching :cg.picture-widget + :cg.picture-widget.palette :cg.pixmap + :cg.pixmap-widget :cg.pixmap.file-io + :cg.pixmap.printing :cg.pixmap.rotate + :cg.printing :cg.progress-indicator + :cg.project-window :cg.property + :cg.radio-button :cg.rich-edit + :cg.rich-edit-pane + :cg.rich-edit-pane.clipboard + :cg.rich-edit-pane.printing + :cg.sample-file-menu :cg.scaling-stream + :cg.scroll-bar :cg.scroll-bar-mixin + :cg.selected-object :cg.shortcut-menu + :cg.static-text :cg.status-bar + :cg.string-dialog :cg.tab-control + :cg.template-string :cg.text-edit-pane + :cg.text-edit-pane.file-io + :cg.text-edit-pane.mark :cg.text-or-combo + :cg.text-widget :cg.timer :cg.toggling-widget + :cg.toolbar :cg.tooltip :cg.trackbar :cg.tray + :cg.up-down-control :cg.utility-dialog + :cg.web-browser :cg.web-browser.dde + :cg.wrap-string :cg.yes-no-list + :cg.yes-no-string :dde) :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") - :include-flags '(:compiler :top-level :local-name-info) - :build-flags '(:allow-debug :purify) + :include-flags (list :compiler :top-level :local-name-info) + :build-flags (list :allow-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil + :include-manifest-file-for-visual-styles t :default-command-line-arguments "+cx +t \"Initializing\"" - :additional-build-lisp-image-arguments '(:read-init-files nil) + :additional-build-lisp-image-arguments (list :read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard

1 0

[cello-cvs] CVS cello/cffi-extender
by ktilton 11 Apr '08

11 Apr '08

Update of /project/cello/cvsroot/cello/cffi-extender In directory clnet:/tmp/cvs-serv7403/cffi-extender Modified Files: cffi-extender.lpr Log Message: --- /project/cello/cvsroot/cello/cffi-extender/cffi-extender.lpr 2007/02/02 20:11:02 1.8 +++ /project/cello/cvsroot/cello/cffi-extender/cffi-extender.lpr 2008/04/11 09:22:55 1.9 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Sep 14, 2007 21:56)"; cg: "1.81"; -*- (in-package :cg-user)

1 0

[cello-cvs] CVS cello/cellodemo
by ktilton 11 Apr '08

11 Apr '08

Update of /project/cello/cvsroot/cello/cellodemo In directory clnet:/tmp/cvs-serv7403/cellodemo Modified Files: cellodemo.lisp demo-window.lisp hedron-decoration.lisp hedron-render.lisp light-panel.lisp tutor-geometry.lisp Log Message: --- /project/cello/cvsroot/cello/cellodemo/cellodemo.lisp 2006/06/03 12:05:55 1.3 +++ /project/cello/cvsroot/cello/cellodemo/cellodemo.lisp 2008/04/11 09:22:55 1.4 @@ -42,8 +42,8 @@ :kids (c? (the-kids (a-row (:px 96 :py (downs 96)) (mk-part :imk-jpg (ix-image-file) - :pre-layer (c? (with-layers +red+ :fill (:wand (^wander)))) - :md-value (c? (demo-image-file "shapers" "grace.jpg"))) + :pre-layer (c? (with-layers +red+ :fill (:wand (^value)))) + :value (c? (demo-image-file "shapers" "grace.jpg"))) (a-stack () (loop for face in '(antquabi bookosb georgiai framd times @@ -56,22 +56,22 @@ (c? (font-ftgl-ensure :texture myface 24))) :text$ "Hello, world!")))) (mk-part :zee (ix-text) - :md-value (c? (if (visible (fm-other :ft-jpg)) - (without-c-dependency (frame-ct .w.)) 0)) + :value (c? (if (visible (fm-other :ft-jpg)) + (without-c-dependency (frame-ct .togl)) 0)) :px (c? (px-maintain-pl (pl (psib)))) :justify-hz :center :py (c? (py-maintain-pt (pb (psib)))) :pre-layer (with-layers (:out 1500) +blue+) - :zoom (c? (let ((start (^md-value))) - (if (without-c-dependency (< 200 (- (frame-ct .w.) start))) + :zoom (c? (let ((start (^value))) + (if (without-c-dependency (< 200 (- (frame-ct .togl) start))) .cache - (make-list 3 :initial-element (min 2.0 (/ (- (frame-ct .w.) start) + (make-list 3 :initial-element (min 2.0 (/ (- (frame-ct .togl) start) 100.0)))))) - :rotation (c? (let ((start (^md-value))) - (if (without-c-dependency (< 200 (- (frame-ct .w.) start))) + :rotation (c? (let ((start (^value))) + (if (without-c-dependency (< 200 (- (frame-ct .togl) start))) .cache - (list (* 360 (/ (min 200 (- (frame-ct .w.) start)) 100.0)) + (list (* 360 (/ (min 200 (- (frame-ct .togl) start)) 100.0)) 1 1 1)))) :text-font (c? (font-ftgl-ensure :texture *gui-style-default-face* 24 )) --- /project/cello/cvsroot/cello/cellodemo/demo-window.lisp 2006/08/24 09:33:46 1.6 +++ /project/cello/cvsroot/cello/cellodemo/demo-window.lisp 2008/04/11 09:22:55 1.7 @@ -32,12 +32,12 @@ #+no demo-scroller) 'tu-geo :skin (c? (wand-ensure-typed 'wand-texture - (car (md-value (fm-other :texture-picker))))) + (car (value (fm-other :texture-picker))))) :lb (c-in (downs 1000))))) -(defun demo-scroller () +(defun demo-scroller (self) (mk-part :demo-scroller (ix-zero-tl) - :kids (c? (list + :kids (c? (the-kids (mk-part :dialog (ix-zero-tl) :px 48 :py -48 :outset (u8ths 2) @@ -68,12 +68,12 @@ :resizeable t :content (c? (mk-part :gview (ix-image-file) :wand-type 'wand-pixels - :md-value (demo-image-file "shapers" "mandelbrot3.gif"))))))) + :value (demo-image-file "shapers" "mandelbrot3.gif"))))))) (defun run-demos (demo-names start-at &rest iargs) (declare (ignorable start-at)) (run-window (apply 'make-instance 'demo-window - :md-value (c-in (list start-at)) + :value (c-in (list start-at)) :content demo-names iargs) (lambda () @@ -129,7 +129,7 @@ ;; :diffuse *dim* ;; :specular *bright*)) - :recording nil #+(or) (c? (when (md-value (fm-other :record)) + :recording nil #+(or) (c? (when (value (fm-other :record)) (make-recording :wand (magick-wand-template) :splice-wand (magick-wand-template) @@ -144,7 +144,7 @@ :lighting :on ;; :clear-rgba (list 0 0 0 1) ;; :light-model (c? (bwhen (lm (fm-other? :light-model)) -;; (list (md-value lm)))) +;; (list (value lm)))) :snapshot-pathnamer (lambda (self) (make-pathname @@ -162,7 +162,7 @@ (:out 500))) :clipped nil :kids (c? (the-kids - (demo-window-beef) + (demo-window-beef self) #+nicetry (mk-part :wintop (ix-zero-tl) :px 0 :py 0 @@ -202,14 +202,14 @@ (ix-sound-find self :close))) (wav-play-till-end nil (car (sound-paths s))))) -(defun demo-window-beef () +(defun demo-window-beef (self) (mk-part :beef (ix-inline) :orientation :vertical :px 0 :py (u8ths (downs 1)) :spacing (u8ths 1) :lb (c? (^fill-parent-down)) :kids (c? (the-kids - (demo-control-panel) + (demo-control-panel self) (mk-part :demos (ix-zero-tl) ;;:py (u8ths 4) :lb (c? (^fill-parent-down)) @@ -218,24 +218,24 @@ (list (mk-kid-slot (visible) (c? (string-equal (md-name self) - (car (md-value .w.))))) + (car (value .w.))))) (mk-kid-slot (px) (c? (px-maintain-pl 0))) (mk-kid-slot (py) (c? (py-maintain-pt 0))))) :kids (let (demos-built) - (c? (bwhen (demo-factory (car (md-value .w.))) + (c? (bwhen (demo-factory (car (value .w.))) (unless (assoc demo-factory demos-built) (pushnew (cons demo-factory (funcall demo-factory)) demos-built))) (mapcar 'cdr demos-built)))))))) -(defun demo-control-panel () +(defun demo-control-panel (self) (a-row (:spacing (u8ths 2) :justify :center) - (mk-part :rate (frame-rate-text)) + ;;(mk-part :rate (frame-rate-text)) (a-stack (:spacing (u16ths 1)) - (texture-picker) - (demo-picker)) + (texture-picker self) + (demo-picker self)) (a-stack (:spacing (u96ths 6) :justify :center :outset (u96ths 6) @@ -247,12 +247,12 @@ +yellow+ ))) - (alabel "just shoot me!" + (a-label "just shoot me!" :text-font (c? (ftgl-font-ensure :texture 'stacc222 14 96)) :pre-layer (c? (with-layers +yellow+ :fill +gray+))) (mk-part :record (ct-push-toggle) - :md-value (c-in nil) + :value (c-in nil) :title$ "record") (mk-part :snapshot (ct-button) :title$ "snapshot" @@ -266,14 +266,14 @@ (incf snap-count)))))))) -(defun texture-picker (&aux (backdrops +(defun texture-picker (self &aux (backdrops (directory (demo-image-subdir "window-bkgs")))) (a-row (:spacing (u8ths 1)) - (alabel "Skins") + (a-label "Skins") (mk-part :texture-picker (ct-radio-row) :spacing (upts 4) - :md-value (c-in (let ((jpegs backdrops)) + :value (c-in (let ((jpegs backdrops)) (list (or (find-if (lambda (jpeg) (search "concrete" (pathname-name jpeg))) jpegs) @@ -288,9 +288,9 @@ :title$ (pathname-name p))) backdrops))))) -(defun demo-picker () +(defun demo-picker (self) (a-row (:spacing (u8ths 1) :justify :center) - (alabel "Demos") + (a-label "Demos") (mk-part :demo (ix-row) :spacing (upts 4) :clipped nil @@ -302,30 +302,25 @@ (format nil "~d" s)))) (content .w.)))))) - - -(defun nested-windows () +(defun nested-windows (self) (a-row (:md-name 'nested-windows :px 0 :py 0 :spacing (upts 10)) (a-stack () - (starter-toolbar) - (starter-hedron)) + (starter-toolbar self) + (starter-hedron self)) (mk-part :socket (window-socket) :px (uin 2) :window-factory (lambda (socket glut-xy) (declare (ignorable socket)) (make-instance 'demo-window - :md-value (c-in (list (car (content .w.)))) + :value (c-in (list (car (content .w.)))) :content (content .w.) :glut-xy glut-xy)) - :gen-window-p (c? (md-value (cells::fm-find-one (upper self window) + :gen-window-p (c? (value (cells::fm-find-one (upper self window) :nested :must-find t :skip-tree self)))))) - - - (defparameter *starter-font* nil) (defparameter *rot* 0) @@ -333,7 +328,7 @@ (defparameter *idle-angle* 0) -(defun starter-toolbar () +(defun starter-toolbar (self) (a-row (:spacing (upts 10)) (mk-part :hw (ct-button) ;:inset (mkv2 (uPts 4)(uPts 2)) @@ -355,31 +350,10 @@ (kids *sys*)))) (mk-part :nested (ct-check-text) - :md-value (c-in nil) + :value (c-in nil) :title$ "Nested"))) -(defun starter-flag () - (a-row (:lighting :off) - (mk-part :one (ix-view) - :ll (u8ths -2) :lt 0 :lr (u8ths 2) :lb (downs (u8ths 2)) - :lighting nil - :pre-layer (with-layers +red+ (:x-mark t))) - (mk-part :canvasflag (ix-canvas-kid-sized) - :target-res 96 - :kids (the-kids - (mk-part :two (ix-view) - :px 0 :py 0 - :ll (u8ths -2) :lt 0 :lr (u8ths 2) :lb (downs (u8ths 2)) - :bkg-color (c? (trc nil "s mi" self (mouse-view .w.) - (^mouse-over-p)) - (if (^mouse-over-p) - +black+ +blue+)) - :pre-layer (with-layers (:rgba (^bkg-color)) :fill))) - :pre-layer (with-layers +black+)) - (mk-part :tree (ix-view) - :ll (u8ths -2) :lt 0 :lr (u8ths 2) :lb (downs (u8ths 2)) - :pre-layer (with-layers +green+ :fill)) - )) + --- /project/cello/cvsroot/cello/cellodemo/hedron-decoration.lisp 2006/06/03 12:05:55 1.2 +++ /project/cello/cvsroot/cello/cellodemo/hedron-decoration.lisp 2008/04/11 09:22:55 1.3 @@ -33,23 +33,23 @@ (mk-part :spinning (ct-check-text) :title$ "spinning") (mk-part :wireframe (ct-check-text) - :md-value (c-in t) + :value (c-in t) :title$ "wireframe" :clipped nil :enabled t)) (a-stack () - (alabel "line width") + (a-label "line width") (make-slider :line-width :initial-pcts (list (mkv2 .05 .05)))) (a-stack () - (alabel "spin") + (a-label "spin") (make-slider :rotx :initial-pcts (list (mkv2 .15 .15))) (make-slider :roty :initial-pcts (list (mkv2 .15 .15))) (make-slider :rotz :initial-pcts (list (mkv2 .15 .15)))) (a-stack () - (alabel "scale") + (a-label "scale") (make-slider :scalex) (make-slider :scaley) (make-slider :scalez)) @@ -58,41 +58,41 @@ :justify :right) (a-stack () - (alabel "color") + (a-label "color") (make-rgba-mixer :hedro-color :alpha 1 :init-all .5)) (a-stack (:collapsed t) - (alabel "specular") + (a-label "specular") (make-rgba-mixer :hedro-specular :init-all .8)) (a-stack () - (alabel "shiny") + (a-label "shiny") (make-slider :hedro-shiny))) (a-stack () (mk-part :lights-on (ct-check-text) - :md-value (c-in t) + :value (c-in t) :title$ "glowing") (make-rgba-mixer :hedro-emission :init-all 0.3)) - (shape-options) + (shape-options self) )))) -(defun hedron-tex-options () +(defun hedron-tex-options (self) (mk-part :tex-options (ix-inline) :orientation :vertical :justify :left :kids (c? (the-kids (a-row () - (hedron-shapes) + (hedron-shapes self) (test-image-group :shape-backer "window-bkgs" "hedron-bkgs") (test-image-group :shape-skin "Skin" "shapers" "cloudy")) - (hedron-texxing))))) + (hedron-texxing self))))) -(defun hedron-shapes () +(defun hedron-shapes (self) (a-stack () - (alabel "Shape/Sides") + (a-label "Shape/Sides") (mk-part :scroller (ix-scroller) :mac-p t :scroll-bars '(:vertical) @@ -101,7 +101,7 @@ :content (c? (mk-part :shape (ix-inline) :orientation :vertical :pre-layer (with-layers +white+ :fill) - :md-value (c-in (list 'nurb)) + :value (c-in (list 'nurb)) :kids (c? (loop for shape in '(nurb cube 4 8 12 rhombic-dodecahedron 20 cylinder cone sphere torus sierpinski-sponge teapot cello) @@ -109,7 +109,7 @@ :radio self :associated-value shape :already-on-do nil - :text-color (c? (if (^md-value) + :text-color (c? (if (^value) +red+ +black+)) :pre-layer (c? (with-layers (:rgba (^text-color)))) @@ -118,7 +118,7 @@ :text$ (string-downcase (format nil "~d" shape)))))))))) -(defun hedron-texxing () +(defun hedron-texxing (self) (a-row (:spacing (u8ths 2)) (a-row () (let ((styles `((object . ,gl_object_linear) @@ -126,11 +126,11 @@ (sphere . ,gl_sphere_map)))) (mk-part :tex-gen (ct-radio-row) :spacing (upts 4) - :md-value (c-in (list gl_object_linear)) + :value (c-in (list gl_object_linear)) :clipped nil :kids (c? (mapcar (lambda (s) (mk-part :rb (ct-radio-push-button) - ;;:md-value (c? (see-if-on self)) + ;;:value (c? (see-if-on self)) :associated-value (cdr s) ;;:radio (c? (find-radio self)) :inset (mkv2 2 2) @@ -141,7 +141,7 @@ (let ((styles `((repeat . ,gl_repeat)(clamp . ,gl_clamp)))) (mk-part :tex-wrap (ct-radio-row) :spacing (upts 4) - :md-value (c-in (list gl_repeat)) + :value (c-in (list gl_repeat)) :clipped nil :kids (c? (mapcar (lambda (s) (mk-part :rb (ct-radio-push-button) @@ -153,17 +153,17 @@ -(defun hedron-backers () - (test-image-group :shape-backer "window-bkgs" "hedron-bkgs")) +(defun hedron-backers (self) + (test-image-group self :shape-backer "window-bkgs" "hedron-bkgs")) -(defun test-image-group (md-name label$ dir-name$ &optional start$) +(defun test-image-group (self md-name label$ dir-name$ &optional start$) (let ((jpegs (mapcan (lambda (type) (directory (merge-pathnames (make-pathname :type type) (demo-image-subdir dir-name$)))) '("jpg" "bmp" "gif" "tif")))) (a-stack () - (alabel label$) + (a-label label$) (mk-part :scroller (ix-scroller) :mac-p t :scroll-bars '(:vertical) @@ -172,7 +172,7 @@ :content (c? (make-part md-name 'ix-inline :orientation :vertical :pre-layer (with-layers +white+ :fill) - :md-value (c-in (list (or (when start$ + :value (c-in (list (or (when start$ (find-if (lambda (jpeg) (search start$ (namestring jpeg))) jpegs)) @@ -183,7 +183,7 @@ :radio self :associated-value p :already-on-do :off - :text-color (c? (if (^md-value) + :text-color (c? (if (^value) +red+ +black+)) :pre-layer (c? (with-layers (:rgba (^text-color)))) --- /project/cello/cvsroot/cello/cellodemo/hedron-render.lisp 2006/06/03 12:05:55 1.2 +++ /project/cello/cvsroot/cello/cellodemo/hedron-render.lisp 2008/04/11 09:22:55 1.3 @@ -117,41 +117,41 @@ (gl-matrix-mode gl_modelview) (with-matrix (nil) - (let ((shape (car (md-value (fm^ :shape)))) - (wireframe-p (md-value (fm^ :wireframe))) - (tex-gen (or (car (md-value (fm^ :tex-gen))) + (let ((shape (car (value (fm^ :shape)))) + (wireframe-p (value (fm^ :wireframe))) + (tex-gen (or (car (value (fm^ :tex-gen))) gl_sphere_map)) - (tex-wrap (or (car (md-value (fm^ :tex-wrap))) + (tex-wrap (or (car (value (fm^ :tex-wrap))) gl_sphere_map)) - (line-width (or (md-value (fm^ :line-width)) + (line-width (or (value (fm^ :line-width)) (mkv2 4 0))) - (scalex (or (md-value (fm^ :scalex)) + (scalex (or (value (fm^ :scalex)) (mkv2 0 0))) - (scaley (or (md-value (fm^ :scaley)) + (scaley (or (value (fm^ :scaley)) (mkv2 0 0))) - (scalez (or (md-value (fm^ :scalez)) + (scalez (or (value (fm^ :scalez)) (mkv2 0 0))) - (size (or (md-value (fm^ :size)) + (size (or (value (fm^ :size)) 1)) - (height (or (md-value (fm^ :height)) + (height (or (value (fm^ :height)) 1)) - (base-r (or (md-value (fm^ :base-r)) + (base-r (or (value (fm^ :base-r)) 1)) - (top-r (or (md-value (fm^ :top-r)) + (top-r (or (value (fm^ :top-r)) 1)) - (inner-r (or (md-value (fm^ :inner-r)) + (inner-r (or (value (fm^ :inner-r)) 0.5)) - (outer-r (or (md-value (fm^ :outer-r)) + (outer-r (or (value (fm^ :outer-r)) 0.5)) - (sides (or (md-value (fm^ :sides)) + (sides (or (value (fm^ :sides)) 1)) - (rings (or (md-value (fm^ :rings)) + (rings (or (value (fm^ :rings)) 1)) - (slices (or (md-value (fm^ :slices)) + (slices (or (value (fm^ :slices)) 1)) - (stacks (or (md-value (fm^ :stacks)) + (stacks (or (value (fm^ :stacks)) 1)) - (levels (or (md-value (fm^ :levels)) + (levels (or (value (fm^ :levels)) 1)) ) (if (skin self) @@ -165,7 +165,7 @@ (cube .5) (cello ;(gl-translatef -100 0 0) ;;-1440) (rpchk 'hedron t nil self) - ;;(trc "evaluating md-value" self) + ;;(trc "evaluating value" self) .5) (torus .5) --- /project/cello/cvsroot/cello/cellodemo/light-panel.lisp 2006/11/03 13:38:24 1.6 +++ /project/cello/cvsroot/cello/cellodemo/light-panel.lisp 2008/04/11 09:22:55 1.7 @@ -43,13 +43,13 @@ :lighting :on :text-font (ftgl-make :extruded *gui-style-default-face* 18 96 9) :rotation (let ((rx 0)(ry 0)(rz 0)) - (c? (bIf (spinning (md-value (fm-other :spinning))) + (c? (bIf (spinning (value (fm-other :spinning))) (macrolet ((radj (axis ixid) `(incf ,axis (if spinning - (* 10 (v2-h (md-value (fm-other ,ixid)))) + (* 10 (v2-h (value (fm-other ,ixid)))) 0)))) - (when (frame-ct .w.) + (when (frame-ct .togl) (list (radj rx :rotx) (radj ry :roty) (radj rz :rotz)))) @@ -83,10 +83,10 @@ :sound `((:click . ,(lambda (self) (declare (ignore self)) (make-sound :paths '("click") :gain .5 :source :default)))) - :md-value (c? (^rgba-value)) + :value (c? (^rgba-value)) :rgba-value (c? (make-rgba :fo (apply 'make-floatv (mapcar (lambda (k) - (v2-h (md-value k))) (^kids))))) + (v2-h (value k))) (^kids))))) :kids (c? (mapcar (lambda (c) (make-slider c :initial-pcts (list (mkv2 (or (slot-value self c) @@ -96,7 +96,7 @@ (defun make-rgba-mixer (md-name &rest iargs) (apply 'make-part md-name 'rgba-mixer iargs)) -(defun light-panel () +(defun light-panel (self) (a-row (:md-name 'light-panel ;; :px (u8ths 4) :py (u8ths (downs 4)) :lb (c? (^fill-parent-down)) :spacing (u8ths 2) :justify :top @@ -104,11 +104,11 @@ (a-stack (:spacing (u8ths 1) :justify :right) (a-stack ( :justify :right) - (alabel "Light model") + (a-label "Light model") (mk-part :light-model (rgba-mixer) :red .20 - :md-value (c? (cons gl_light_model_ambient (rgba-fo (^rgba-value)))))) - (alabel "World Color") + :value (c? (cons gl_light_model_ambient (rgba-fo (^rgba-value)))))) + (a-label "World Color") (make-rgba-mixer :world-color) (a-row () (make-lighting :light0 gl_light0 *light-pos-tl*) @@ -117,7 +117,7 @@ ;(make-lighting :light3 GL_LIGHT3 *LightPosTR*) )) - (starter-hedron))) + (starter-hedron self))) (defun make-lighting (md-name id pos) (make-instance 'ix-light @@ -125,26 +125,26 @@ :id id :initial-pos pos)) -(defun starter-hedron () +(defun starter-hedron (self) (a-row (:outset (u8ths 1) :spacing (u8ths 1) :lb (c? (^fill-parent-down))) (hedron-options) (a-stack (:spacing (u8ths 1) :justify :left) - (hedron-tex-options) + (hedron-tex-options self) (mk-part :hedron (hedron) :ll (u96ths -300) :lt (ups (u96ths 300)) :lr (u96ths 300) :lb (downs (u96ths 300)) :clipped t :lighting :on - :mat-ambi-diffuse (c? (md-value (fm-other :hedro-color))) - :mat-specular (c? (md-value (fm-other :hedro-specular))) - :mat-shiny (c? (v2-h (md-value (fm-other :hedro-shiny)))) - :mat-emission (c? (when (md-value (fm-other :lights-on)) - (md-value (fm-other :hedro-emission)))) + :mat-ambi-diffuse (c? (value (fm-other :hedro-color))) + :mat-specular (c? (value (fm-other :hedro-specular))) + :mat-shiny (c? (v2-h (value (fm-other :hedro-shiny)))) + :mat-emission (c? (when (value (fm-other :lights-on)) + (value (fm-other :hedro-emission)))) :backdrop (c? (assert (not *ogl-listing-p*)) (wand-ensure-typed 'wand-texture - (car (md-value (fm-other :shape-backer))) + (car (value (fm-other :shape-backer))) :tile-p nil)) :pre-layer (with-layers (:in 300) @@ -160,11 +160,11 @@ +white+) :skin (c? (wand-ensure-typed 'wand-texture - (car (md-value (fm^ :shape-skin))))))))) + (car (value (fm^ :shape-skin))))))))) -(defun shape-options () +(defun shape-options (self) (a-stack (:justify :right) (loop for spec in '((:size 5)(:height 5) (:base-r 5) (:top-r 5) @@ -176,11 +176,11 @@ :spacing (upts 2) :justify :center :visible (c? (find id (shape-ids - (car (md-value (without-c-dependency + (car (value (without-c-dependency (fm^ :shape)))))))) - (alabel (string-downcase id)) + (a-label (string-downcase id)) (make-slider id - :md-value-fn (lambda (drag-pct) + :value-fn (lambda (drag-pct) (* (expt (v2-h drag-pct) 2) max)))))))) (defmethod shape-ids ((shape (eql 'cone))) @@ -209,21 +209,21 @@ (defmodel ix-light (light ix-stack) ((initial-pos :initarg :initial-pos :initform nil :accessor initial-pos)) (:default-initargs - :md-value nil #+(or) (c? (when (md-value (fm-other :enabled)) + :value nil #+(or) (c? (when (value (fm-other :enabled)) (make-instance 'light :id id))) - :enabled (c? (md-value (fm-other :enabled))) - :pos (c? (md-value (fm-other :xyz-pos))) - :ambient (c? (rgba-fo (md-value (fm-other :ambient)))) - :diffuse (c? (rgba-fo (md-value (fm-other :diffuse)))) - :specular (c? (rgba-fo (md-value (fm-other :specular)))) - :cutoff (c? (round (* 180 (v2-h (md-value (fm-other :cutoff)))))) - :spot-exp (c? (round (* 128 (v2-h (md-value (fm-other :spot-exponent)))))) + :enabled (c? (value (fm-other :enabled))) + :pos (c? (value (fm-other :xyz-pos))) + :ambient (c? (rgba-fo (value (fm-other :ambient)))) + :diffuse (c? (rgba-fo (value (fm-other :diffuse)))) + :specular (c? (rgba-fo (value (fm-other :specular)))) + :cutoff (c? (round (* 180 (v2-h (value (fm-other :cutoff)))))) + :spot-exp (c? (round (* 128 (v2-h (value (fm-other :spot-exponent)))))) :justify :right :spacing (u16ths 1) :kids (c? (the-kids (mk-part :enabled (ct-check-text) - :md-value (c-in t) + :value (c-in t) :title$ "on/off";;(c? (string-downcase (string (md-name (upper self ix-light))))) :clipped nil :enabled t) @@ -233,18 +233,18 @@ ;;:justify-hz :right :text-font (font-ftgl-ensure :texture 'arialn 10) :pre-layer (with-layers +black+) - :text$ (c? (let ((fpos (md-value (fm-other :xyz-pos)))) + :text$ (c? (let ((fpos (value (fm-other :xyz-pos)))) (format nil "~6,,,d ~6,,,d ~6,,,d" (round (eltf fpos 0)) (round (eltf fpos 1))(round (eltf fpos 2)))))) (a-row (:md-name :xyz-pos - :md-value (c? (eko (nil "xyz c?") + :value (c? (eko (nil "xyz c?") (let* ((ks (^kids)) - (xy (md-value (car ks)))) + (xy (value (car ks)))) (make-ff-array :float (pct-xlate (v2-h xy) (ll .w.) (lr .w.) .30) (pct-xlate (v2-v xy) (lb .w.) (lt .w.) .50) - (eko (nil "light pos z" (v2-v (md-value (second ks)))) - (pct-xlate (v2-v (md-value (second ks))) + (eko (nil "light pos z" (v2-v (value (second ks)))) + (pct-xlate (v2-v (value (second ks))) *mgw-near* *mgw-far* 1.5)) 1))))) (make-slider :xy-pos @@ -255,7 +255,7 @@ :width (u8ths 1) :height (u8ths 5))) (a-stack (:justify :right) - (alabel "cutoff/spot") + (a-label "cutoff/spot") (make-slider :cutoff :initial-pcts (list (mkv2 .75 0)) :width (u8ths 4) @@ -265,11 +265,11 @@ :width (u8ths 4) :height (u8ths 1))) (a-stack (:justify :right) - (alabel "ambient") + (a-label "ambient") (make-rgba-mixer :ambient :init-all 0.1)) (a-stack (:justify :right) - (alabel "diffusion") + (a-label "diffusion") (make-rgba-mixer :diffuse)) (a-stack (:justify :right :visible nil :collapsed t) - (alabel "specular") + (a-label "specular") (make-rgba-mixer :specular)))))) --- /project/cello/cvsroot/cello/cellodemo/tutor-geometry.lisp 2006/06/26 17:05:20 1.3 +++ /project/cello/cvsroot/cello/cellodemo/tutor-geometry.lisp 2008/04/11 09:22:55 1.4 @@ -57,15 +57,15 @@ (tu-box :ftgrow :px 300 :py -500 :skin +yellow+ - :md-value (c? (degree-radians (mod (frame-ct .w.) 360))) - :ll (c? (+ -62.5 (* 62.5 (cos (^md-value))))) - :lt (c? (+ 62.5 (* -62.5 (sin (^md-value)))))) + :value (c? (degree-radians (mod (frame-ct .togl) 360))) + :ll (c? (+ -62.5 (* 62.5 (cos (^value))))) + :lt (c? (+ 62.5 (* -62.5 (sin (^value)))))) (mk-part :bye (ct-button) :px (c? (/ (l-width .w.) 2)) :py (c? (downs (/ (l-height .w.) 2))) :text$ "Close" :ct-action (lambda (self event) - (declare (ignorable event)) + (declare (ignorable self event)) (ctk::tcl-eval-ex ctk::*tki* "{destroy .}"))))))))

1 0