From ktilton at common-lisp.net Fri Nov 3 13:38:24 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 3 Nov 2006 08:38:24 -0500 (EST) Subject: [cello-cvs] CVS cello Message-ID: <20061103133824.8796E54004@common-lisp.net> Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv32009 Modified Files: ctl-toggle.lisp image.lisp ix-layer-expand.lisp lighting.lisp Log Message: --- /project/cello/cvsroot/cello/ctl-toggle.lisp 2006/10/28 18:22:43 1.7 +++ /project/cello/cvsroot/cello/ctl-toggle.lisp 2006/11/03 13:38:24 1.8 @@ -50,9 +50,9 @@ :style-id :button :skin (c? (skin .w.)) :text-color (c? (cond - ((not (^enabled)) +red+) + ((not (^enabled)) +dark-gray+) ((^depressed) +dark-gray+) - (t +white+))) + (t +black+))) :pre-layer (c? (let* ((thick (min (u96ths 4) (* 0.08 (l-width self)))) (defl (if (clo::^depressed) (downs (/ thick 3)) 0)) (push-in (if (clo::^depressed) (xlout (* .5 thick)) 0))) @@ -166,6 +166,8 @@ (not (md-value tw))))) ,twisted-widget))) + + #| vestigial? (defmacro mk-twisted (twisted-name (label-class &rest label-args) --- /project/cello/cvsroot/cello/image.lisp 2006/10/17 21:30:08 1.15 +++ /project/cello/cvsroot/cello/image.lisp 2006/11/03 13:38:24 1.16 @@ -179,7 +179,7 @@ (defobserver mouse-over-p () (bwhen (p .parent) (when (typep p 'ix-view) - (with-integrity(:change 'mose-over) + (with-integrity(:change 'mouse-over) (setf (mouse-over-p p) new-value))))) (defmethod ix-selectable ((self ix-view)) nil) --- /project/cello/cvsroot/cello/ix-layer-expand.lisp 2006/10/28 18:22:43 1.9 +++ /project/cello/cvsroot/cello/ix-layer-expand.lisp 2006/11/03 13:38:24 1.10 @@ -145,7 +145,7 @@ (defmethod ix-layer-expand ((self (eql :mat-shiny)) &rest values) `(progn (gl-disable gl_color_material) - (gl-materialf gl_front gl_shininess (* 128.0f0 (v2-h ,(car values)))))) + (gl-materialf gl_front gl_shininess (* 128.0f0 ,(car values))))) (defmethod ix-layer-expand ((self (eql :mat-emission)) &rest values) (let ((emission (gensym))) --- /project/cello/cvsroot/cello/lighting.lisp 2006/10/06 08:01:51 1.7 +++ /project/cello/cvsroot/cello/lighting.lisp 2006/11/03 13:38:24 1.8 @@ -58,16 +58,16 @@ :initform (list (make-instance 'light :id gl_light6 :enabled t - :pos (make-ff-array :float 200 (downs 300) (nearer 1200) 1) + :pos (make-ff-array :float 0 0 (nearer 1200) 1) ;; 200 (downs 300) :ambient *dim* :diffuse *bright* :specular *bright*) (make-instance 'light :id gl_light1 :enabled t - :pos (make-ff-array :float 700 (downs 600) (nearer 200) 1) + :pos (make-ff-array :float 0 0 (nearer 200) 1) ;; 700 (downs 600) :ambient *dim* - :diffuse *average* + :diffuse *dim* ;; *average* :specular *bright*))))) (defmethod ix-paint :before ((self ogl-lit-scene)) From ktilton at common-lisp.net Fri Nov 3 13:38:24 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 3 Nov 2006 08:38:24 -0500 (EST) Subject: [cello-cvs] CVS cello/cellodemo Message-ID: <20061103133824.BD8CC54004@common-lisp.net> Update of /project/cello/cvsroot/cello/cellodemo In directory clnet:/tmp/cvs-serv32009/cellodemo Modified Files: light-panel.lisp Log Message: --- /project/cello/cvsroot/cello/cellodemo/light-panel.lisp 2006/06/26 17:05:20 1.5 +++ /project/cello/cvsroot/cello/cellodemo/light-panel.lisp 2006/11/03 13:38:24 1.6 @@ -139,7 +139,7 @@ :lighting :on :mat-ambi-diffuse (c? (md-value (fm-other :hedro-color))) :mat-specular (c? (md-value (fm-other :hedro-specular))) - :mat-shiny (c? (md-value (fm-other :hedro-shiny))) + :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)))) :backdrop (c? (assert (not *ogl-listing-p*)) From ktilton at common-lisp.net Fri Nov 3 13:38:24 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 3 Nov 2006 08:38:24 -0500 (EST) Subject: [cello-cvs] CVS cello/cl-ftgl Message-ID: <20061103133824.0073B5400D@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-ftgl In directory clnet:/tmp/cvs-serv32009/cl-ftgl Modified Files: cl-ftgl.lpr Log Message: --- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2006/08/28 21:45:24 1.8 +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2006/11/03 13:38:24 1.9 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- (in-package :cg-user) From ktilton at common-lisp.net Fri Nov 3 13:38:25 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 3 Nov 2006 08:38:25 -0500 (EST) Subject: [cello-cvs] CVS cello/cl-magick Message-ID: <20061103133825.3148E5400D@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-magick In directory clnet:/tmp/cvs-serv32009/cl-magick Modified Files: cl-magick.lpr Log Message: --- /project/cello/cvsroot/cello/cl-magick/cl-magick.lpr 2006/08/31 17:34:48 1.7 +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lpr 2006/11/03 13:38:25 1.8 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- (in-package :cg-user) From ktilton at common-lisp.net Fri Nov 3 13:38:25 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 3 Nov 2006 08:38:25 -0500 (EST) Subject: [cello-cvs] CVS cello/cl-openal Message-ID: <20061103133825.60F1B54004@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-openal In directory clnet:/tmp/cvs-serv32009/cl-openal Modified Files: cl-openal.lpr Log Message: --- /project/cello/cvsroot/cello/cl-openal/cl-openal.lpr 2006/08/31 17:34:49 1.9 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal.lpr 2006/11/03 13:38:25 1.10 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- (in-package :cg-user) From ktilton at common-lisp.net Fri Nov 3 13:38:28 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 3 Nov 2006 08:38:28 -0500 (EST) Subject: [cello-cvs] CVS cello/kt-opengl Message-ID: <20061103133828.9F0B259089@common-lisp.net> Update of /project/cello/cvsroot/cello/kt-opengl In directory clnet:/tmp/cvs-serv32009/kt-opengl Modified Files: colors.lisp kt-opengl.lpr Log Message: --- /project/cello/cvsroot/cello/kt-opengl/colors.lisp 2006/10/17 21:30:08 1.6 +++ /project/cello/cvsroot/cello/kt-opengl/colors.lisp 2006/11/03 13:38:25 1.7 @@ -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.6 2006/10/17 21:30:08 ktilton Exp $ +;;; $Id: colors.lisp,v 1.7 2006/11/03 13:38:25 ktilton Exp $ (in-package #:kt-opengl) @@ -236,10 +236,13 @@ (define-ogl-rgba-color +DARK-GRAY+ 64 64 64 255) (define-ogl-rgba-color +LIGHT-BLUE+ 127 127 255 255) -(define-ogl-rgba-color +YELLOW+ 255 255 127 255) +(define-ogl-rgba-color +YELLOW+ 255 255 0 255) +(define-ogl-rgba-color +gold+ 255 215 0 255) (define-ogl-rgba-color +LIGHT-YELLOW+ 255 255 127 255) (define-ogl-rgba-color +LIGHT-GRAY+ 192 192 192 255) +(define-ogl-rgba-color +orange+ 192 192 192 255) + ;;; PANTONE colors as defined by graphics design s/w Art Director's Toolkit V.5 ;;; PANTONE SOLID COATED --- /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lpr 2006/10/02 03:55:23 1.6 +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lpr 2006/11/03 13:38:25 1.7 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- (in-package :cg-user) From ktilton at common-lisp.net Sat Nov 4 20:56:30 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 4 Nov 2006 15:56:30 -0500 (EST) Subject: [cello-cvs] CVS cello Message-ID: <20061104205630.EE60D78001@common-lisp.net> Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv32241 Modified Files: cello-ftgl.lisp cello-magick.lisp cello.lpr ctl-markbox.lisp ctl-selectable.lisp ctl-toggle.lisp image.lisp ix-paint.lisp ix-togl.lisp nehe-06.lisp slider.lisp wm-mouse.lisp Log Message: md-value -> value --- /project/cello/cvsroot/cello/cello-ftgl.lisp 2006/10/13 07:59:12 1.9 +++ /project/cello/cvsroot/cello/cello-ftgl.lisp 2006/11/04 20:56:30 1.10 @@ -47,7 +47,7 @@ (:default-initargs :style nil :pre-layer (with-layers - (:rgba (if (^md-value) +red+ +black+))) + (:rgba (if (^value) +red+ +black+))) :text-font (c? (font-ftgl-ensure :texture (intern (^font-pathname)) 14)) :text$ (c? (string-capitalize @@ -56,7 +56,7 @@ (defobserver mouse-over-p ((self font-id)) (when new-value - (setf (md-value (fm-other :ftgl-test)) (^font-pathname)))) + (setf (value (fm-other :ftgl-test)) (^font-pathname)))) (export! gui-style-ftgl) @@ -152,13 +152,13 @@ (eko ("font show") (elt fns (+ (* cols row-no) col-no))))))))) (a-stack (:md-name :ftgl-test :spacing (upts 10) :px 0 :py (uin 1) - :md-value (c-in (car fns)) + :value (c-in (car fns)) :justify :left :outset (u8ths 1)) (a-stack (:lb (downs (upts 64)) :justify :center :outset (upts 8) - :pre-layer (c? (when (md-value (fm-other :ftgl-test)) + :pre-layer (c? (when (value (fm-other :ftgl-test)) (with-layers :on +gray+ (:frame-3d :edge-sunken :thickness (u96ths 4)) @@ -172,13 +172,13 @@ :style nil :pre-layer (with-layers +black+) :text-font (c? (font-ftgl-ensure - (car (md-value (fm-other :mode))) - (intern (md-value (fm-other :ftgl-test))) + (car (value (fm-other :mode))) + (intern (value (fm-other :ftgl-test))) 18 ;; (* 12 (1+ (mod x 4))) ))))) (mk-part :mode (ct-radio-row) :spacing (upts 4) - :md-value (c-in (list :texture)) + :value (c-in (list :texture)) :clipped nil :kids (c? (loop for mode in '(:bitmap :pixmap :texture :outline :polygon :extruded) collect (mk-part :rb (ct-radio-labeled) --- /project/cello/cvsroot/cello/cello-magick.lisp 2006/07/06 22:09:10 1.5 +++ /project/cello/cvsroot/cello/cello-magick.lisp 2006/11/04 20:56:30 1.6 @@ -61,11 +61,11 @@ (defmodel ix-image-file (ix-wander) ((wand-type :initarg :wand-type :accessor wand-type :initform 'wand-pixels)) (:default-initargs - :wander (c? (if (^md-value) - (let ((wand (wand-ensure-typed (^wand-type) (^md-value)))) - (assert wand () "Unable to load image file ~a" (^md-value)) + :wander (c? (if (^value) + (let ((wand (wand-ensure-typed (^wand-type) (^value)))) + (assert wand () "Unable to load image file ~a" (^value)) wand) - (error "ix-image-file requires md-value of path to image file"))) + (error "ix-image-file requires value of path to image file"))) :pre-layer (c? (with-layers +white+ (:wand (^wander)))) :ll 0 :lt 0 :lb (c? (downs (cdr (image-size (^wander))))) :lr (c? (car (image-size (^wander)))) --- /project/cello/cvsroot/cello/cello.lpr 2006/10/17 21:30:08 1.14 +++ /project/cello/cvsroot/cello/cello.lpr 2006/11/04 20:56:30 1.15 @@ -58,7 +58,7 @@ (make-instance 'project-module :name "cl-magick\\cl-magick") (make-instance 'project-module :name - "..\\Celtk\\CELTK")) + "..\\Celtk\\CELLOTK")) :libraries nil :distributed-files nil :internally-loaded-files nil --- /project/cello/cvsroot/cello/ctl-markbox.lisp 2006/10/28 18:22:43 1.9 +++ /project/cello/cvsroot/cello/ctl-markbox.lisp 2006/11/04 20:56:30 1.10 @@ -39,7 +39,7 @@ :off +dark-gray+ (:out 4) - (:x-mark (^md-value))))) + (:x-mark (^value))))) (defun ix-render-x-mark (do-p lbox &optional thickness &aux (thick (or thickness (/ (r-width lbox) 4)))) (when do-p @@ -65,22 +65,22 @@ (radio :initarg :radio :accessor radio :initform (c? (upper self ct-radio)))) (:default-initargs :enabled t - :md-value (c? (find (associated-value self) (md-value (^radio)))) + :value (c? (find (associated-value self) (value (^radio)))) :ct-action (lambda (self event) (with-c-change :ct-radio-item - (radio-item-to-md-value self event (^radio)))))) + (radio-item-to-value self event (^radio)))))) -(defun radio-item-to-md-value (self event radio) +(defun radio-item-to-value (self event radio) (declare (ignorable event)) - (trc nil "radio item acts" self (md-value self) (already-on-do self) .w.) - (if (md-value self) + (trc nil "radio item acts" self (value self) (already-on-do self) .w.) + (if (value self) (ecase (already-on-do self) ((nil)) - (:off (setf (md-value radio) nil))) + (:off (setf (value radio) nil))) (progn (trc nil "here come rb" (associated-value self) radio) - (setf (md-value radio) + (setf (value radio) (list (associated-value self)))))) (defmodel ct-radio-button (ct-mark-box ct-radio-item) ()) @@ -88,9 +88,9 @@ (defmd ct-radio (ix-inline) on-change - :md-value (c-in nil)) + :value (c-in nil)) -(defobserver .md-value ((self ct-radio)) ;; /// should every control have this? +(defobserver .value ((self ct-radio)) ;; /// should every control have this? (when (^on-change) (trcx nil radio-value-observer self new-value old-value old-value-boundp) (funcall (^on-change) self new-value old-value old-value-boundp))) @@ -99,12 +99,12 @@ () (:default-initargs :orientation :horizontal - :md-value (c-in nil))) + :value (c-in nil))) (defmodel ct-radio-stack (ct-radio) () (:default-initargs - :md-value (c-in nil) + :value (c-in nil) :orientation :vertical)) (defun radio-on-name (radio-values) @@ -120,20 +120,20 @@ () (:default-initargs :lighting :on - :md-value (c-in nil)) + :value (c-in nil)) ) (defmodel ct-check-text (control ix-row) () (:default-initargs - :md-value (c-in nil) + :value (c-in nil) :justify :center :spacing (u96ths 8) :outset (u96ths 2) :kids (c? (the-kids (make-kid 'ct-check-box :md-name :check-box - :md-value (c? (md-value .parent)) + :value (c? (value .parent)) :enabled nil) ;; let parent handle clicks since text is clickable by the rules (make-kid 'ix-text :md-name :label @@ -142,9 +142,9 @@ :ct-action (lambda (self event) (declare (ignorable event)) - (trc nil "checktext bingo" (not (md-value self))) + (trc nil "checktext bingo" (not (value self))) (with-c-change :check-text-action - (setf (md-value self) (not (md-value self))))))) + (setf (value self) (not (value self))))))) (defmodel ct-radio-labeled (ix-row ct-radio-item) () @@ -154,7 +154,7 @@ :outset (u96ths 2) :kids (c? (the-kids (mk-part :rbutton (ct-check-box) - :md-value (c? (md-value .parent)) + :value (c? (value .parent)) :enabled nil) ;; let parent handle clicks since text is clickable by the rules (mk-part :label (ix-text) @@ -169,7 +169,7 @@ () (:default-initargs :inset (mkv2 (upts 4) (upts 4)) - :depressed (c? (or (^hilited)(^md-value))) + :depressed (c? (or (^hilited)(^value))) )) (defmethod ix-paint ((self ct-radio-push-button)) @@ -183,4 +183,4 @@ (defmodel ct-push-toggle (ct-toggle ct-button) () (:default-initargs - :md-value (c-in nil))) + :value (c-in nil))) --- /project/cello/cvsroot/cello/ctl-selectable.lisp 2006/06/05 01:47:49 1.3 +++ /project/cello/cvsroot/cello/ctl-selectable.lisp 2006/11/04 20:56:30 1.4 @@ -69,7 +69,7 @@ (defmodel ct-selectable (control) ((selectedp :initarg :selectedp :initform (c? (bwhen (selector (ct-selector self)) - (member (^md-value) (selection selector)))) + (member (^value) (selection selector)))) :reader selectedp)) (:default-initargs :ct-action (lambda (self event @@ -77,7 +77,7 @@ (buttons (evt-buttons event)) (selector (ct-selector self)) (selection (selection selector)) - (value (^md-value)) + (value (^value)) (now-selected (member value selection))) (if (multiple-choice-p selector) (if now-selected --- /project/cello/cvsroot/cello/ctl-toggle.lisp 2006/11/03 13:38:24 1.8 +++ /project/cello/cvsroot/cello/ctl-toggle.lisp 2006/11/04 20:56:30 1.9 @@ -22,7 +22,7 @@ () (:default-initargs :style-id :default - :text$ (c? (string (^md-value))) + :text$ (c? (string (^value))) :inset (mkv2 (u96ths 2)(u96ths 2)) :lighting :off :text-color (c? (if (^enabled) @@ -34,14 +34,14 @@ (defmd ct-button (control ix-text) ;; same inheritance, but otherwise unrelated to CTText - (md-value (c-in nil) :cell :ephemeral) + (value (c-in nil) :cell :ephemeral) (inset (mkv2 (upts 4) (upts 4)) :unchanged-if 'v2=) (depressed (c? (^hilited))) :ct-action (lambda (self event) (declare (ignore event)) (with-c-change :button-press .retog. - (setf (^md-value) t))) + (setf (^value) t))) :title$ (c? (string-capitalize (md-name self))) :text$ (c? (^title$)) :clipped t @@ -102,7 +102,7 @@ (states :cell nil :initarg :states :reader states) ) (:default-initargs - :md-value (c-in nil) + :value (c-in nil) :transition-fn (lambda (current-state state-table) ;(trc "CTFSM :transitionFN curr,table" currentstate statetable) (or (cadr (member current-state state-table :test (if (stringp current-state) @@ -113,11 +113,11 @@ :ct-action (lambda (self event) (declare (ignorable event)) (with-integrity (:change :ctfsm-action) - (let ((newv (funcall (transition-fn self) (md-value self) (states self)))) + (let ((newv (funcall (transition-fn self) (value self) (states self)))) (ct-fsm-assume-value self newv)))))) (defmethod ct-fsm-assume-value (self new-value) - (setf (md-value self) new-value)) + (setf (value self) new-value)) ; --------------- CT Toggle ----------------------- @@ -135,13 +135,13 @@ ; () (:default-initargs - :md-value (c-in nil) ;;; closed by default + :value (c-in nil) ;;; closed by default :poly-style :fill :pre-layer (c? (with-layers (:poly-mode gl_front_and_back gl_fill) (:rgba (if (^hilited) +green+ +black+)))) - :vertices (c? (if (md-value self) + :vertices (c? (if (value self) '((2 . -4) (7 . -9) (12 . -4)) '((4 . -2) (9 . -7) (4 . -12)))) :ll 0 :lt 0 :lr (u96ths 15) :lb (downs (u96ths 15)))) @@ -153,7 +153,7 @@ (a-row () (make-kid 'ct-twister :md-name :show-contents - :md-value (c-in ,initial-open) + :value (c-in ,initial-open) :visible (c? (^enabled)) , at twister-args) ,(if (stringp label) @@ -163,7 +163,7 @@ label)) ;; actually should be a form to build a widget (a-stack (:collapsed (c? (let ((tw (fm^ :show-contents))) (assert (eq .parent (fm-parent (fm-parent tw)))) - (not (md-value tw))))) + (not (value tw))))) ,twisted-widget))) @@ -177,7 +177,7 @@ :ll (c? (geo-kid-wrap self 'pl)) :lr (c? (geo-kid-wrap self 'pr)) :kids (c? (let ((thetree self)) - ;; (trc "making all parts of tree for" (md-value self) rethinker) + ;; (trc "making all parts of tree for" (value self) rethinker) (the-kids (mk-part 'ix-kid-sized :ll (u96ths -20) :px 0 --- /project/cello/cvsroot/cello/image.lisp 2006/11/03 13:38:24 1.16 +++ /project/cello/cvsroot/cello/image.lisp 2006/11/04 20:56:30 1.17 @@ -83,6 +83,7 @@ :initform (c? (or .cache (^showkids))) :reader kids-ever-shown))) +(export! ix-zero-tl) (defmodel ix-zero-tl (geo-zero-tl ix-family)()) (defmodel ix-kid-sized (geo-kid-sized ix-family)()) (defmodel ix-inline (geo-inline ix-view)()) --- /project/cello/cvsroot/cello/ix-paint.lisp 2006/10/02 03:55:23 1.7 +++ /project/cello/cvsroot/cello/ix-paint.lisp 2006/11/04 20:56:30 1.8 @@ -73,7 +73,7 @@ (ix-selectable self)) (visible self) (not (collapsed self))) - (progn ;;with-clipping (self) + (progn ;; with-clipping (self) (progn ;; with-attrib (gl_lighting_bit gl_texture_bit gl_enable_bit gl_hint_bit gl_line_bit gl_color_buffer_bit) (count-it :ix-render) #+(or) (count-it :ix-paint (type-of self)) --- /project/cello/cvsroot/cello/ix-togl.lisp 2006/10/28 18:22:43 1.14 +++ /project/cello/cvsroot/cello/ix-togl.lisp 2006/11/04 20:56:30 1.15 @@ -178,14 +178,11 @@ (defun buttons-shifted (buttons) #+glut (logtest buttons glut_active_shift) - (find :shift-key buttons) - ) + (find :shift-key buttons)) (defun shift-key-down (buttons) #+glut (logtest buttons glut_active_shift) - (find :shift-key buttons) - ) - + (find :shift-key buttons)) (defun control-key-down (buttons) #+glut (logtest buttons glut_active_ctrl) --- /project/cello/cvsroot/cello/nehe-06.lisp 2006/09/05 23:05:36 1.11 +++ /project/cello/cvsroot/cello/nehe-06.lisp 2006/11/04 20:56:30 1.12 @@ -38,7 +38,7 @@ (make-instance 'nehe06 :fm-parent *parent* :width 700 :height 500 - :timer-interval 2 #+later (c? (let ((n$ (md-value (fm-other :vtime)))) + :timer-interval 2 #+later (c? (let ((n$ (value (fm-other :vtime)))) (format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0))))) :double 1 ;; "yes" )))))) --- /project/cello/cvsroot/cello/slider.lisp 2006/10/17 21:30:08 1.5 +++ /project/cello/cvsroot/cello/slider.lisp 2006/11/04 20:56:30 1.6 @@ -41,7 +41,7 @@ (:frame-3d :edge-raised :thickness (u96ths 3)))) (tracked-pct :initarg :tracked-pct :initform nil :accessor tracked-pct) - (md-value-fn :initarg :md-value-fn :initform nil :accessor md-value-fn) + (value-fn :initarg :value-fn :initform nil :accessor value-fn) (jumper-action :initarg :jumper-action :reader jumper-action :initform 'ix-slider-jumper-action) (jumper-layers :initarg :jumper-layers :reader jumper-layers @@ -51,8 +51,8 @@ ) (:default-initargs :ll 0 :lt 0 - :md-value (c? (let ((vs (loop for k in (rest (^kids)) - collecting (funcall (or (^md-value-fn) 'identity) + :value (c? (let ((vs (loop for k in (rest (^kids)) + collecting (funcall (or (^value-fn) 'identity) (drag-pct k))))) (if (cdr vs) vs (car vs)))) :kids (c? (the-kids @@ -88,12 +88,12 @@ (trc nil "tracked-pct output sets slider" self) (slider-set self new-value))) -(defun make-slider (md-name &key (md-value-fn 'identity) +(defun make-slider (md-name &key (value-fn 'identity) (initial-pcts (list (mkv2 .50 .50))) (width (uin 1)) (height (u8ths 1))) (make-part md-name 'ix-slider :lr width :lb (downs height) - :md-value-fn md-value-fn + :value-fn value-fn :initial-pcts initial-pcts)) (defun slider-set (self value) --- /project/cello/cvsroot/cello/wm-mouse.lisp 2006/10/17 21:30:08 1.5 +++ /project/cello/cvsroot/cello/wm-mouse.lisp 2006/11/04 20:56:30 1.6 @@ -49,10 +49,16 @@ (defun evt-buttons (os-event) (modifiers os-event)) +(defun evt-shift-key-down (os-event) + (shift-key-down (evt-buttons os-event))) + +(defun evt-control-key-down (os-event) + (control-key-down (evt-buttons os-event))) + (defun evt-where (os-event) (where os-event)) -(export! evt-c-event) +(export! evt-c-event evt-shift-key-down evt-control-key-down) (defun evt-c-event (os-event) (c-event os-event)) From ktilton at common-lisp.net Mon Nov 13 05:29:27 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 13 Nov 2006 00:29:27 -0500 (EST) Subject: [cello-cvs] CVS cello Message-ID: <20061113052927.A03BF53010@common-lisp.net> Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv11178 Modified Files: application.lisp cello-openal.lisp cello-window.lisp cello.lpr control.lisp ctl-markbox.lisp ctl-toggle.lisp focus-utilities.lisp focus.lisp ix-grid.lisp ix-togl.lisp Log Message: --- /project/cello/cvsroot/cello/application.lisp 2006/10/13 08:04:45 1.8 +++ /project/cello/cvsroot/cello/application.lisp 2006/11/13 05:29:26 1.9 @@ -34,7 +34,7 @@ (cl-ftgl-reset) ;; 2006-09-27 back in temporarily ... ;; new 2006-08-28: in face of weird OGL 1282 when ;; new chars hit in ratios - + (mgk::wands-clear) ;; Init global *sys* ... needed for Cello context ops (when system-type (setf *sys* (make-instance system-type :md-name 'mgsys))) --- /project/cello/cvsroot/cello/cello-openal.lisp 2006/07/06 22:09:10 1.4 +++ /project/cello/cvsroot/cello/cello-openal.lisp 2006/11/13 05:29:26 1.5 @@ -18,6 +18,8 @@ (defstruct sound paths (gain 1) callback loopingp start (source :default) buffer sources) +(export! make-sound ix-sound-install ix-play-start) + (defun ix-sound-install (self sound) (when (and sound (cl-openal-init)) (ix-play-start self sound) @@ -72,11 +74,16 @@ (pathname (make-sound :paths (list (merge-pathnames sound-spec oal::*audio-files*)))))) +(merge-pathnames (make-pathname :directory '(:relative "mistakes")) + oal::*audio-files*) + (defun ix-sound-spec-find (self key) (when (typep self 'ix-view) (or (cdr (assoc key (sound self))) (ix-sound-spec-find .parent key)))) +(export! sound-manager sounds sources) + (defmodel sound-manager () ((sources :initarg :sources :accessor sources :initform (list (cons :default (car (al-source-gen 1))))) --- /project/cello/cvsroot/cello/cello-window.lisp 2006/10/17 21:30:08 1.6 +++ /project/cello/cvsroot/cello/cello-window.lisp 2006/11/13 05:29:26 1.7 @@ -59,7 +59,7 @@ (:MotionNotify (trc "we got motion!!!!")) (:EnterNotify ) (:LeaveNotify ) - (:FocusIn ) + (:FocusIn (TRC "cello-window-event-handler" self (ctk::tk-event-type (ctk::xsv type xe)) )) (:FocusOut ) (:KeymapNotify ) (:Expose ) --- /project/cello/cvsroot/cello/cello.lpr 2006/11/04 20:56:30 1.15 +++ /project/cello/cvsroot/cello/cello.lpr 2006/11/13 05:29:26 1.16 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cello/cvsroot/cello/control.lisp 2006/10/28 18:22:43 1.7 +++ /project/cello/cvsroot/cello/control.lisp 2006/11/13 05:29:26 1.8 @@ -20,6 +20,7 @@ (title$ (c? (format nil "~:(~a~)" ;; this is just a poor default-- really s.b. supplied by form author (string-downcase (substitute #\space #\- (string (md-name self))))))) (ct-action nil :cell nil) + sound click-repeat-p (click-repeat-event (c? (bwhen (c (^click-evt)) (let ((age (f-sensitivity :age (0.1) @@ -36,6 +37,8 @@ (kb-selector nil :cell nil) :gl-name (c? (incf (gl-name-highest .w.)))) +(defmethod kb-selector (other) (declare (ignore other)) nil) + (defobserver click-repeat-event () (with-integrity (:change :obs-click-repeat-event) (when new-value --- /project/cello/cvsroot/cello/ctl-markbox.lisp 2006/11/04 20:56:30 1.10 +++ /project/cello/cvsroot/cello/ctl-markbox.lisp 2006/11/13 05:29:26 1.11 @@ -22,24 +22,21 @@ (defmethod ix-layer-expand ((self (eql :x-mark)) &rest args) `(ix-render-x-mark ,(car args) l-box ,(cadr args)))) -(defmodel ct-mark-box (ct-toggle ix-view) - ((kb-selector :cell nil :initarg :kb-selector :initform nil :reader kb-selector) - ) - (:default-initargs - :ll (- *mark-box-size*) - :lt (ups *mark-box-size*) - :lr *mark-box-size* - :lb (downs *mark-box-size*) - :skin nil ;;(c? (skin .w.)) - :pre-layer (with-layers - (:in 4) - +light-gray+ ;;;(if (^enabled) +white+ +gray+) - :off - (:frame-3d :edge-sunken :thickness 4) - :off - +dark-gray+ - (:out 4) - (:x-mark (^value))))) +(defmd ct-mark-box (ct-toggle ix-view) + :ll (- *mark-box-size*) + :lt (ups *mark-box-size*) + :lr *mark-box-size* + :lb (downs *mark-box-size*) + :skin nil ;;(c? (skin .w.)) + :pre-layer (with-layers + (:in 4) + +light-gray+ ;;;(if (^enabled) +white+ +gray+) + :off + (:frame-3d :edge-sunken :thickness 4) + :off + +dark-gray+ + (:out 4) + (:x-mark (^value)))) (defun ix-render-x-mark (do-p lbox &optional thickness &aux (thick (or thickness (/ (r-width lbox) 4)))) (when do-p @@ -67,7 +64,7 @@ :enabled t :value (c? (find (associated-value self) (value (^radio)))) :ct-action (lambda (self event) - (with-c-change :ct-radio-item + (with-cc :ct-radio-item (radio-item-to-value self event (^radio)))))) @@ -92,7 +89,7 @@ (defobserver .value ((self ct-radio)) ;; /// should every control have this? (when (^on-change) - (trcx nil radio-value-observer self new-value old-value old-value-boundp) + (trcx radio-value-observer self new-value old-value old-value-boundp) (funcall (^on-change) self new-value old-value old-value-boundp))) (defmodel ct-radio-row (ct-radio) @@ -143,7 +140,7 @@ :ct-action (lambda (self event) (declare (ignorable event)) (trc nil "checktext bingo" (not (value self))) - (with-c-change :check-text-action + (with-cc :check-text-action (setf (value self) (not (value self))))))) (defmodel ct-radio-labeled (ix-row ct-radio-item) @@ -184,3 +181,6 @@ () (:default-initargs :value (c-in nil))) + +(export! ct-dot-grid) +(defmd ct-dot-grid (control ix-dot-grid)) \ No newline at end of file --- /project/cello/cvsroot/cello/ctl-toggle.lisp 2006/11/04 20:56:30 1.9 +++ /project/cello/cvsroot/cello/ctl-toggle.lisp 2006/11/13 05:29:26 1.10 @@ -32,6 +32,8 @@ :pre-layer (with-layers :off +white+ :fill (:rgba (^text-color))))) +(export! ix-control ct-action kb-selector) +(defmd ix-control (ix-view control)) (defmd ct-button (control ix-text) ;; same inheritance, but otherwise unrelated to CTText (value (c-in nil) :cell :ephemeral) @@ -39,7 +41,7 @@ (depressed (c? (^hilited))) :ct-action (lambda (self event) (declare (ignore event)) - (with-c-change :button-press + (with-cc :button-press .retog. (setf (^value) t))) :title$ (c? (string-capitalize (md-name self))) @@ -89,7 +91,7 @@ :title$ ,text :ct-action (lambda (self event) (declare (ignorable self event)) - (with-c-change :ct-button-ex-ct-action + (with-cc :ct-button-ex-ct-action ,command)) , at initargs)) @@ -104,7 +106,7 @@ (:default-initargs :value (c-in nil) :transition-fn (lambda (current-state state-table) - ;(trc "CTFSM :transitionFN curr,table" currentstate statetable) + (trc "CTFSM :transitionFN curr,table" current-state state-table) (or (cadr (member current-state state-table :test (if (stringp current-state) #'string-equal #'eql))) @@ -112,9 +114,10 @@ :ct-action (lambda (self event) (declare (ignorable event)) - (with-integrity (:change :ctfsm-action) - (let ((newv (funcall (transition-fn self) (value self) (states self)))) - (ct-fsm-assume-value self newv)))))) + (trc "twister ct-action" self event) + (with-integrity (:change :ctfsm-action) + (let ((newv (funcall (transition-fn self) (value self) (states self)))) + (ct-fsm-assume-value self newv)))))) (defmethod ct-fsm-assume-value (self new-value) (setf (value self) new-value)) @@ -146,24 +149,34 @@ '((4 . -2) (9 . -7) (4 . -12)))) :ll 0 :lt 0 :lr (u96ths 15) :lb (downs (u96ths 15)))) +(defmethod (setf .value) :around (new (self ct-twister)) + (trcx ct-twister-value-set!!!!!!!!!!!! self new) + (call-next-method)) + +(defobserver .value ((self ct-twister)) + (when (eq :show-contents (md-name self)) + (trcx contents-twister-value-changing!!!!!!! new-value old-value old-value-boundp))) + (export! a-twister) (defmacro a-twister ((label component-args initial-open &rest twister-args) twisted-widget) `(a-stack (, at component-args) (a-row () - (make-kid 'ct-twister - :md-name :show-contents - :value (c-in ,initial-open) - :visible (c? (^enabled)) - , at twister-args) + (or (car .cache) + (make-kid 'ct-twister + :md-name :show-contents + :value (c-in ,initial-open) + :visible (c? (^enabled)) + , at twister-args)) ,(if (stringp label) `(make-kid 'ix-text :text$ ,label :style-id :button) label)) ;; actually should be a form to build a widget - (a-stack (:collapsed (c? (let ((tw (fm^ :show-contents))) - (assert (eq .parent (fm-parent (fm-parent tw)))) - (not (value tw))))) + (a-stack (:collapsed (c? (eko ("collapsed!!!!!!!!!!!!" .cause) + (let ((tw (fm^ :show-contents))) + (assert (eq .parent (fm-parent (fm-parent tw)))) + (not (value tw)))))) ,twisted-widget))) --- /project/cello/cvsroot/cello/focus-utilities.lisp 2006/06/26 17:05:20 1.4 +++ /project/cello/cvsroot/cello/focus-utilities.lisp 2006/11/13 05:29:26 1.5 @@ -40,7 +40,7 @@ (defmethod focus-on (self &optional focuser) (c-assert (or self focuser)) - ;;(trc "focus-on self, focuser" self focuser) + (trc "focus-on self, focuser" self focuser) (setf (focus (or focuser (s-focuser))) self)) (defmethod focus-gain (self) --- /project/cello/cvsroot/cello/focus.lisp 2006/07/06 22:09:10 1.4 +++ /project/cello/cvsroot/cello/focus.lisp 2006/11/13 05:29:26 1.5 @@ -40,45 +40,45 @@ (defmodel focuser (ix-canvas) ( (focus :initarg :focus - :initform (c-in nil) - :accessor focus) + :initform (c-in nil) + :accessor focus) (textual-focus :initarg :textual-focus - :initform nil #+chya (c? (bwhen (focus (and #+runtime-system (activep (swdw)) - (^focus))) - (when (and (typep focus 'ct-text) ;; possibly any 'IXText? - (^edit-active)) - focus))) - :accessor textual-focus) - + :initform nil #+chya (c? (bwhen (focus (and #+runtime-system (activep (swdw)) + (^focus))) + (when (and (typep focus 'ct-text) ;; possibly any 'IXText? + (^edit-active)) + focus))) + :accessor textual-focus) + (edit-active :initarg :edit-active - :initform (c-in nil) - :accessor edit-active) - - (insertion-pt :initform (c-in 0) - :initarg :insertion-pt - :accessor insertion-pt) - - (sel-end :initform (c-in nil) - :accessor sel-end) - - (sel-range :documentation "selEnd identified during drag operation" - :reader sel-range :initarg :sel-range - :initform nil #+chya (c? (bwhen (focus (^textual-focus)) - (bwhen (click-evt (click-evt focus)) - (bwhen (mp (in-drag click-evt)) - (cttext-find-ip focus mp)))))) - - (undo-data :cell nil :initarg :undo-data :accessor undo-data - :initform nil #+hunh (new-undo-data) - :documentation "Data structure holding undo information" - ) + :initform (c-in nil) + :accessor edit-active) + + (insertion-pt :initform (c-in 0) + :initarg :insertion-pt + :accessor insertion-pt) + + (sel-end :initform (c-in nil) + :accessor sel-end) + + (sel-range :documentation "selEnd identified during drag operation" + :reader sel-range :initarg :sel-range + :initform nil #+chya (c? (bwhen (focus (^textual-focus)) + (bwhen (click-evt (click-evt focus)) + (bwhen (mp (in-drag click-evt)) + (cttext-find-ip focus mp)))))) + + (undo-data :cell nil :initarg :undo-data :accessor undo-data + :initform nil #+hunh (new-undo-data) + :documentation "Data structure holding undo information" ) - (:default-initargs - :kids (c? (the-kids (^content) - ; (mkPart :caret (CTEditcaret)) - ; (mkPart :selBox (IXEditSelection)) - )))) + ) + (:default-initargs + :kids (c? (the-kids (^content) + ; (mkPart :caret (CTEditcaret)) + ; (mkPart :selBox (IXEditSelection)) + )))) (defun focuser (self) (swdw) --- /project/cello/cvsroot/cello/ix-grid.lisp 2006/06/05 01:47:49 1.2 +++ /project/cello/cvsroot/cello/ix-grid.lisp 2006/11/13 05:29:26 1.3 @@ -208,3 +208,43 @@ (elt (kids grid) (+ (* row-no (col-ct grid)) col-no))) +;;; --- ix dot grid ---------------------------------------------------------- + +(export! ix-dot-grid dot-color ^dot-color dot-size ^dot-size) + +(defmd ix-dot-grid (ix-view) + dot-color + (dot-size 6) + (rows (c? (when (numberp (^value)) + (floor (sqrt (abs (^value))))))) + (columns (c? (when (and (numberp (^value)) + (numberp (^rows)) + (plusp (^rows))) + (ceiling (abs (^value)) (^rows))))) + :ll (c? (if (^collapsed) + 0 (- (v2-h (^inset))))) + :lt (c? (if (^collapsed) + 0 (ups (v2-v (^inset))))) + :lb (c? (if (^collapsed) + 0 (+ (downs (* 2 (v2-v (^inset)))) + (* (^rows) (- (+ 2 (^dot-size)))) + -2))) + :lr (c? (if (^collapsed) + 0 (+ (* 2 (v2-h (^inset))) + (* (+ 2 (^dot-size)) (^columns)) + -2))) + :pre-layer (c? (with-layers :off +gray+ :fill + (:poly-mode gl_front_and_back gl_fill) + (:rgba (^dot-color))))) + +(defmethod ix-paint ((self ix-dot-grid)) + (let ((spacing 2) + (offset (ceiling (^dot-size) 2))) + (gl-point-size (^dot-size)) + (gl-enable gl_point_smooth) + (with-gl-translation ((+ offset (v2-h (^inset))) (downs (+ offset (v2-v (^inset))))) + (with-gl-begun (gl_points) + (loop for pn below (abs (^value)) + for row = (mod pn (^rows)) + for col = (floor pn (^rows)) + do (gl-vertex2f (* col (+ spacing (^dot-size)))(* row (- (+ spacing (^dot-size)))))))))) --- /project/cello/cvsroot/cello/ix-togl.lisp 2006/11/04 20:56:30 1.15 +++ /project/cello/cvsroot/cello/ix-togl.lisp 2006/11/13 05:29:26 1.16 @@ -280,7 +280,7 @@ (defmethod togl-reshape-using-class ((self ix-togl) &aux (width (ctk::togl-width (ctk::togl-ptr self))) (height (ctk::togl-height (ctk::togl-ptr self)))) (let ((ctk::*tki* (ctk::togl-interp (ctk::togl-ptr self)))) - (trc nil "mg-window-reshape" self width height) + (trc "mg-window-reshape" self width height) (gl-viewport 0 0 width height) (gl-matrix-mode gl_projection) From ktilton at common-lisp.net Mon Nov 13 05:29:27 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 13 Nov 2006 00:29:27 -0500 (EST) Subject: [cello-cvs] CVS cello/cffi-extender Message-ID: <20061113052927.D75A95600C@common-lisp.net> Update of /project/cello/cvsroot/cello/cffi-extender In directory clnet:/tmp/cvs-serv11178/cffi-extender Modified Files: cffi-extender.lpr Log Message: --- /project/cello/cvsroot/cello/cffi-extender/cffi-extender.lpr 2006/10/28 18:22:43 1.6 +++ /project/cello/cvsroot/cello/cffi-extender/cffi-extender.lpr 2006/11/13 05:29:27 1.7 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*- (in-package :cg-user) From ktilton at common-lisp.net Mon Nov 13 05:29:28 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 13 Nov 2006 00:29:28 -0500 (EST) Subject: [cello-cvs] CVS cello/cl-ftgl Message-ID: <20061113052928.137885600C@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-ftgl In directory clnet:/tmp/cvs-serv11178/cl-ftgl Modified Files: cl-ftgl.lpr Log Message: --- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2006/11/03 13:38:24 1.9 +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2006/11/13 05:29:28 1.10 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*- (in-package :cg-user) From ktilton at common-lisp.net Mon Nov 13 05:29:28 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 13 Nov 2006 00:29:28 -0500 (EST) Subject: [cello-cvs] CVS cello/cl-magick Message-ID: <20061113052928.4C22F5600D@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-magick In directory clnet:/tmp/cvs-serv11178/cl-magick Modified Files: cl-magick.lisp cl-magick.lpr Log Message: --- /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2006/10/02 02:59:18 1.13 +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lisp 2006/11/13 05:29:28 1.14 @@ -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.13 2006/10/02 02:59:18 ktilton Exp $ +;;; $Id: cl-magick.lisp,v 1.14 2006/11/13 05:29:28 ktilton Exp $ (defpackage :cl-magick @@ -109,14 +109,14 @@ (when file-path$ (cl-magick-init) (let ((key (list* wand-type (namestring file-path$) iargs))) - (or #+nahhh (let ((old (cdr (assoc key (wands-loaded) :test 'equal)))) + (or (let ((old (cdr (assoc key (wands-loaded) :test 'equal)))) #+shhh (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))) - #+shh (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/11/03 13:38:25 1.8 +++ /project/cello/cvsroot/cello/cl-magick/cl-magick.lpr 2006/11/13 05:29:28 1.9 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*- (in-package :cg-user) From ktilton at common-lisp.net Mon Nov 13 05:29:31 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 13 Nov 2006 00:29:31 -0500 (EST) Subject: [cello-cvs] CVS cello/cl-openal Message-ID: <20061113052931.B218E5B019@common-lisp.net> Update of /project/cello/cvsroot/cello/cl-openal In directory clnet:/tmp/cvs-serv11178/cl-openal Modified Files: cl-openal-init.lisp cl-openal.lisp cl-openal.lpr wav-handling.lisp Log Message: --- /project/cello/cvsroot/cello/cl-openal/cl-openal-init.lisp 2006/08/31 17:34:49 1.7 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal-init.lisp 2006/11/13 05:29:28 1.8 @@ -26,9 +26,12 @@ (defparameter *openal-initialized-p* nil) -(defun cl-openal-init () +#+force +(cl-openal-init t) + +(defun cl-openal-init (&optional force) ;;(return-from cl-openal-init nil) - (when *openal-initialized-p* + (when (and *openal-initialized-p* (not force)) (return-from cl-openal-init t)) #-macosx (xoa) @@ -63,7 +66,7 @@ (format t "~&clear AL error code ~a" (al-get-error)) - (let ((l-zip (make-ff-array al-float 10 0 0)) + (let ((l-zip (make-ff-array al-float 0 0 10)) (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.lisp 2006/08/24 07:55:07 1.4 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal.lisp 2006/11/13 05:29:28 1.5 @@ -22,13 +22,13 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Id: cl-openal.lisp,v 1.4 2006/08/24 07:55:07 fgoenninger Exp $ +;;; $Id: cl-openal.lisp,v 1.5 2006/11/13 05:29:28 ktilton Exp $ (pushnew :cl-openal *features*) (defpackage #:cl-openal (:nicknames #:oal) - (:use #:common-lisp #:cffi #:cffi-extender) + (:use #:common-lisp #:cffi #:cffi-extender #:utils-kt) (:export #:xoa #:al-chk --- /project/cello/cvsroot/cello/cl-openal/cl-openal.lpr 2006/11/03 13:38:25 1.10 +++ /project/cello/cvsroot/cello/cl-openal/cl-openal.lpr 2006/11/13 05:29:28 1.11 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cello/cvsroot/cello/cl-openal/wav-handling.lisp 2006/05/27 06:01:38 1.3 +++ /project/cello/cvsroot/cello/cl-openal/wav-handling.lisp 2006/11/13 05:29:28 1.4 @@ -77,12 +77,56 @@ wav-path *audio-files*))) (assert (probe-file wav-path)() "WAV ~a not found" wav-path) - (let ((buffer (wav-to-buffer wav-path))) + (bwhen (buffer (wav-to-buffer wav-path)) ;; not if OAL does not like the wav file (source-buffer-load source buffer) (al-source-play source) (al-chk "al-Source-Play") source))) +#+test +(go-round) + +(defun go-round () + (loop ;;for wav in (directory (make-pathname :directory '(:absolute "sounds"))) + with wav = (make-pathname :directory '(:absolute "0dev" "user" "sounds") :name "galloping" :type "wav") + with start = (get-internal-real-time) + repeat 4 + do (wav-play-till-end + (lambda (time srcs) + (declare (ignore time srcs)) + (let* ((elapsed (coerce (/ (- (get-internal-real-time) start) internal-time-units-per-second) 'float)) + (angle (* elapsed (/ pi 2))) + (dist 5) + (x (* dist (cos angle))) + (z (* dist (sin angle))) + ) + + ;(cells:trc "time" elapsed srcs) + (let ((l-zip (make-ff-array al-float x 0 z )) + (l-vel (make-ff-array al-float 1 0 0)) + (l-ori (make-ff-array al-float 0 0 -1 0 1 0))) + (declare (ignore l-vel)) + ;(al-listenerfv al_position l-zip) + (al-listenerfv al_position l-zip) + (al-chk "alListenerfv POSITION : ") + + #+noo + (progn + (al-listenerfv al_velocity l-zip) + (al-chk "alListenerfv VELOCITY : ")) + + ;(al-listenerfv al_orientation l-ori) + ;(al-chk "alListenerfv ORIENTATION : ") + (fgn-free l-zip l-ori)))) + wav) + finally (cells:trc "time" (coerce (/ (- (get-internal-real-time) start) internal-time-units-per-second) 'float)))) + +#+test +(source-wav-play-start (car (al-source-gen 1) ) + (make-pathname :directory '(:absolute "0dev" "user" "sounds") + :name "galloping" + :type "wav")) + (defun wav-to-buffer (wav-path) (when (cl-openal-init) (let ((buffer (fgn-alloc 'al-uint 1)) ;; was '(* :void) 1)) ;; was 'aluint @@ -108,10 +152,10 @@ :loop (fgn-pa loop 0))) (when (null-pointer-p (fgn-pa datahandle 0)) ;; 04-11-14 was elti, bad for OpenMCL - (break "null-pointer-p datahandle ~a" datahandle) - (return-from wav-to-buffer nil)) + (format t "~&Cannot handle WAV ~a null-pointer-p datahandle ~a" (namestring wav-path) datahandle (fgn-pa datahandle 0)) + (return-from wav-to-buffer nil)) - (print (list :buffering-data (elti buffer 0) (elti format 0) (fgn-pa datahandle 0) + #+shh (print (list :buffering-data (elti buffer 0) (elti format 0) (fgn-pa datahandle 0) (elti size 0)(elti freq 0))) (al-buffer-data (elti buffer 0) (elti format 0) (fgn-pa datahandle 0) (elti size 0)(elti freq 0)) @@ -120,7 +164,7 @@ (alut-unload-wav (elti format 0)(fgn-pa datahandle 0) (elti size 0)(elti freq 0)) (al-chk "alut-unload-wav") - (format t "~&buffer is ~a" (elti buffer 0)) + ;;(format t "~&buffer is ~a" (elti buffer 0)) (elti buffer 0)) (fgn-free buffer) (fgn-free format) From ktilton at common-lisp.net Mon Nov 13 05:29:34 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 13 Nov 2006 00:29:34 -0500 (EST) Subject: [cello-cvs] CVS cello/kt-opengl Message-ID: <20061113052934.0D570702E9@common-lisp.net> Update of /project/cello/cvsroot/cello/kt-opengl In directory clnet:/tmp/cvs-serv11178/kt-opengl Modified Files: colors.lisp kt-opengl.lpr Log Message: --- /project/cello/cvsroot/cello/kt-opengl/colors.lisp 2006/11/03 13:38:25 1.7 +++ /project/cello/cvsroot/cello/kt-opengl/colors.lisp 2006/11/13 05:29:31 1.8 @@ -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.7 2006/11/03 13:38:25 ktilton Exp $ +;;; $Id: colors.lisp,v 1.8 2006/11/13 05:29:31 ktilton Exp $ (in-package #:kt-opengl) @@ -242,6 +242,7 @@ (define-ogl-rgba-color +LIGHT-GRAY+ 192 192 192 255) (define-ogl-rgba-color +orange+ 192 192 192 255) +(define-ogl-rgba-color +saddle-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/kt-opengl.lpr 2006/11/03 13:38:25 1.7 +++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lpr 2006/11/13 05:29:31 1.8 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*- (in-package :cg-user)