Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv1625
Modified Files: control.lisp ctl-toggle.lisp image.lisp ix-opengl.lisp ix-polygon.lisp ix-text.lisp ix-togl.lisp mouse-click.lisp Log Message:
--- /project/cello/cvsroot/cello/control.lisp 2006/10/02 02:59:18 1.5 +++ /project/cello/cvsroot/cello/control.lisp 2006/10/13 05:57:27 1.6 @@ -16,34 +16,25 @@
(in-package :cello)
-(defmodel control () - ( - (title$ :initarg :title$ :accessor title$ - :initform (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 :cell nil :initarg :ct-action :initform nil :reader ct-action) - (click-repeat-p :initarg :click-repeat-p :initform nil :reader click-repeat-p) - (click-repeat-event :initarg :click-repeat-event - :accessor click-repeat-event - :initform (c? (bwhen (c (^click-evt)) - (let ((age (f-sensitivity :age (0.1) - (click-age c )))) - (when (> age 0.5) age))))) - (mouse-up-handler :initform nil :initarg mouse-up-handler :accessor mouse-up-handler - :documentation "Menus use this") - (click-evt :initform (c-in nil) :initarg :click-evt :accessor click-evt) - (click-tolerance :cell nil :initform (mkv2 0 0) - :unchanged-if 'v2= - :initarg :click-tolerance :reader click-tolerance) - (key-evt :cell :ephemeral :initform nil :initarg :key-evt :accessor key-evt) - (enabled :initform t :initarg :enabled :accessor enabled) - (hilited :initform (c? (bwhen (click (^click-evt)) - (click-over click))) - :initarg :hilited :accessor hilited) - (kb-selector :cell nil :initarg :kb-selector :initform nil :reader kb-selector) - ) - (:default-initargs - :gl-name (c? (incf (gl-name-highest .w.))))) +(defmd control () + (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) + click-repeat-p + (click-repeat-event (c? (bwhen (c (^click-evt)) + (let ((age (f-sensitivity :age (0.1) + (click-age c )))) + (when (> age 0.5) age))))) + (mouse-up-handler nil :documentation "Menus use this") + (click-evt (c-in nil)) + (click-tolerance (mkv2 0 0) :cell nil) + (key-evt nil :cell :ephemeral) + (enabled t) + (hilited (c? (bwhen (click (^click-evt)) + (trc nil "got click!" click) + (click-over click)))) + (kb-selector nil :cell nil) + :gl-name (c? (incf (gl-name-highest .w.))))
(defobserver click-repeat-event () (with-integrity (:change :obs-click-repeat-event) --- /project/cello/cvsroot/cello/ctl-toggle.lisp 2006/10/02 02:59:18 1.4 +++ /project/cello/cvsroot/cello/ctl-toggle.lisp 2006/10/13 05:57:27 1.5 @@ -33,48 +33,55 @@ :fill (:rgba (^text-color)))))
-(defmodel ct-button (control ix-text) ;; same inheritance, but otherwise unrelated to CTText - ((inset :unchanged-if 'v2= :initform (mkv2 (upts 4) (upts 4))) - (depressed :initarg :depressed :reader depressed :initform (c? (^hilited)))) - (:default-initargs - :title$ (c? (string-capitalize (md-name self))) - :text$ (c? (^title$)) - :clipped t - :justify-hz :center - :justify-vt :center - :style-id :button - :skin (c? (skin .w.)) - :text-color (c? (if (^depressed) - +dk-gray+ +white+)) - :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))) - (declare (ignorable thick defl)) - (trc nil "ctbutton" thick defl) - - (with-layers - (:v3f (/ defl 2) defl push-in) - - +white+ - :on - (:frame-3d :edge-raised - :thickness thick - :texturing (list (clo::^skin))) - (:rgba (^text-color)) - ))) - #+old (c? (let* ((thick (min (u96ths 4) (* 0.08 (l-width self)))) - (defl (if (^depressed) (downs (/ thick 3)) 0)) - (push-in (if (^depressed) (xlout (* .5 thick)) 0))) - (declare (ignorable thick defl)) - (trc nil "ctbutton" thick defl) +(defmd ct-button (control ix-text) ;; same inheritance, but otherwise unrelated to CTText + (md-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))) + :title$ (c? (string-capitalize (md-name self))) + :text$ (c? (^title$)) + :clipped t + :justify-hz :center + :justify-vt :center + :style-id :button + :skin (c? (skin .w.)) + :text-color (c? (cond + ((not (^enabled)) +red+) + ((^depressed) +dk-gray+) + (t +white+))) + :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))) + (declare (ignorable thick defl)) + (trc nil "ctbutton" thick defl) + + (with-layers + (:v3f (/ defl 2) defl push-in)
- (with-layers - (:v3f (/ defl 2) defl push-in) - +lt-gray+ - :on - (:frame-3d :edge-raised - :thickness thick) - (:rgba (^text-color))))))) + +white+ + :on + (:frame-3d :edge-raised + :thickness thick + :texturing (list (clo::^skin))) + (:rgba (^text-color)) + ))) + #+old (c? (let* ((thick (min (u96ths 4) (* 0.08 (l-width self)))) + (defl (if (^depressed) (downs (/ thick 3)) 0)) + (push-in (if (^depressed) (xlout (* .5 thick)) 0))) + (declare (ignorable thick defl)) + (trc nil "ctbutton" thick defl) + + (with-layers + (:v3f (/ defl 2) defl push-in) + +lt-gray+ + :on + (:frame-3d :edge-raised + :thickness thick) + (:rgba (^text-color))))))
(defmacro ct-button-ex ((text command) &rest initargs) `(make-instance 'ct-button @@ -105,8 +112,9 @@
:ct-action (lambda (self event) (declare (ignorable event)) - (let ((newv (funcall (transition-fn self) (md-value self) (states self)))) - (ct-fsm-assume-value self newv))))) + (with-integrity (:change :ctfsm-action) + (let ((newv (funcall (transition-fn self) (md-value self) (states self)))) + (ct-fsm-assume-value self newv))))))
(defmethod ct-fsm-assume-value (self new-value) (setf (md-value self) new-value)) @@ -119,40 +127,35 @@ (:default-initargs :states '(nil t)))
- ;------------------------------------------------------ -#+nope + (defmodel ct-twister (ct-toggle ix-polygon) ;; convert to IMBitmapMulti?? -; -; For twist-down control to open/close details -; + ; + ; For twist-down control to open/close details + ; () (:default-initargs :md-value (c-in nil) ;;; closed by default :poly-style :fill - :pre-layer (c? (with-layers (:rgba (if (^hilited) - +black+ +gray+)))) + :pre-layer (c? (with-layers + (:rgba (if (^hilited) + +green+ +black+)))) :vertices (c? (if (md-value self) - (u-cvt '((2 . 4) (7 . 9) (12 . 4)) :96ths) - (u-cvt '((4 . 2) (9 . 7) (4 . 12)) :96ths) - #+big '((0 . 5) (14 . 5) (7 . 12)) - #+big '((5 . 0) (12 . 7) (5 . 14)) - )) + '((2 . -4) (7 . -9) (12 . -4)) + '((4 . -2) (9 . -7) (4 . -12)))) :ll 0 :lt 0 :lr (u96ths 15) :lb (downs (u96ths 15))))
(defmacro mk-twisted (twisted-name (label-class &rest label-args) (twisted-class &rest twisted-args)) - `(mk-part :twisted-group (ix-zero-tl) + `(make-kid :twisted-group (ix-zero-tl) :showkids (c-in nil) :ll (c? (geo-kid-wrap self 'pl)) :lr (c? (geo-kid-wrap self 'pr)) - :kid-factory (lambda (self kid-value) - (declare (ignore self kid-value))) :kids (c? (let ((thetree self)) ;; (trc "making all parts of tree for" (md-value self) rethinker) (the-kids - (mk-part :header (ix-kid-sized) + (mk-part 'ix-kid-sized :ll (u96ths -20) :px 0 :kids (c? (packed-flat! (mk-part :opener (ct-twister) @@ -172,19 +175,19 @@
(defmacro mk-twisted-part (twisted-name (label$ &rest label-args) twisted-part) - `(mk-part :twisted-group (ix-zero-tl) - :showkids (c-in nil) + `(make-kid 'ix-zero-tl + :showkids (c-in nil) ;; /// parameterize :ll (c? (geo-kid-wrap self 'pl)) :lr (c? (geo-kid-wrap self 'pr)) - :kid-factory #'null :kids (c? (the-kids - (mk-part :header (ix-kid-sized) + (make-kid 'ix-kid-sized :ll (u96ths -20) :px 0 :kids (c? (packed-flat! - (mk-part :opener (ct-twister) + (make-kid 'ct-twister :py (u96ths 2) :px (c? (px-maintain-pr (u96ths -3)))) - (mk-part ,twisted-name (ix-text) + (make-kid 'ix-text + :md-name ',twisted-name ,@label-args :text$ ,label$)))) ,twisted-part --- /project/cello/cvsroot/cello/image.lisp 2006/10/02 02:59:18 1.13 +++ /project/cello/cvsroot/cello/image.lisp 2006/10/13 05:57:27 1.14 @@ -81,6 +81,8 @@ :initform (c? (or .cache (^showkids))) :reader kids-ever-shown)))
+(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)()) (defmodel ix-inline-lazy (geo-inline-lazy ix-view)())
--- /project/cello/cvsroot/cello/ix-opengl.lisp 2006/10/02 02:59:18 1.7 +++ /project/cello/cvsroot/cello/ix-opengl.lisp 2006/10/13 05:57:27 1.8 @@ -56,7 +56,7 @@
(define-symbol-macro .og. (or (ogl-context self) - (setf (ogl-context self) (upper self ctk::togl)))) + (setf (ogl-context self) (nearest self ctk::togl))))
(define-symbol-macro .ogc. (togl-ptr .og.)) (define-symbol-macro .retog. (when .ogc. (togl-post-redisplay .ogc.))) --- /project/cello/cvsroot/cello/ix-polygon.lisp 2006/06/26 17:05:20 1.3 +++ /project/cello/cvsroot/cello/ix-polygon.lisp 2006/10/13 05:57:27 1.4 @@ -32,10 +32,10 @@ (append (mapcar #'g2d (vertices self)) (nreverse (mapcar #'sym2d (vertices self)))) (mapcar #'g2d (vertices self))))) + (with-matrix (nil) - (ix-render-layer (fore-color self) nil) - (gl-line-width (poly-thickness self)) - (with-gl-begun (gl_lines) + (gl-line-width (poly-thickness self)) + (with-gl-begun (gl_line_loop) (dolist (v vs) (gl-vertex3f (v2-h v) (v2-v v) 0))) (ogl::glec :f3d)))))) --- /project/cello/cvsroot/cello/ix-text.lisp 2006/10/02 02:59:18 1.9 +++ /project/cello/cvsroot/cello/ix-text.lisp 2006/10/13 05:57:27 1.10 @@ -19,7 +19,7 @@ ;===========================================================
(eval-when (compile load eval) - (export '(ix-paint inset))) + (export '(ix-paint inset ix-text ix-styled ix-view)))
(defmodel ix-text (ix-styled ix-view) ( --- /project/cello/cvsroot/cello/ix-togl.lisp 2006/10/02 02:59:18 1.11 +++ /project/cello/cvsroot/cello/ix-togl.lisp 2006/10/13 05:57:27 1.12 @@ -103,7 +103,7 @@ (:ButtonPress (setf (mouse-pos self) (mkv2 (ctk::xbe-x xe) (- (ctk::xbe-y xe)))) ; trigger mouseview recalc - (setf (mouse-down-evt self) (eko ("mousedown!!!!!!!!!") + (setf (mouse-down-evt self) (eko (nil "mousedown!!!") (make-os-event :modifiers (keyboard-modifiers .tkw) :where (mouse-pos self) @@ -111,14 +111,14 @@ (:ButtonRelease (setf (mouse-pos self) (mkv2 (ctk::xbe-x xe) (- (ctk::xbe-y xe)))) ; trigger mouseview recalc - (setf (mouse-up-evt self) (eko ("mouse up!!!!!!!!!") + (setf (mouse-up-evt self) (eko (nil "mouse up!!!") (make-os-event :modifiers (keyboard-modifiers .tkw) :where (mouse-pos self) :realtime (now)))))
(:MotionNotify - (trc nil "setting mouse pos!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!" (ctk::xbe-x xe) (- (ctk::xbe-y xe))) + (trc nil "setting mouse pos!!!!" (ctk::xbe-x xe) (- (ctk::xbe-y xe))) (setf (mouse-pos self) (mkv2 (ctk::xbe-x xe) (- (ctk::xbe-y xe))))) (:EnterNotify ) @@ -218,8 +218,9 @@ (setf (mouse-over-p new-value) t))))
(defobserver mouse-down-evt (self m-down) + .retog. (when m-down - (trc nil "mousedown" m-down (mouse-control self)) + (trcx nil mousedown self m-down (mouse-control self)) (bwhen (clickee (mouse-control self)) (trc nil "mousedown clickee, clickw" clickee self) (mk-part :click (mouse-click) ;; wow, a free-floating part @@ -229,11 +230,12 @@ :clickee-pxy (mkv2 (px clickee) (py clickee))))))
(defobserver mouse-up-evt (self up) + .retog. (when up ;; should be since this is ephemeral, but still.. - (trc "mouseup" self up (mouse-control self)) + (trc nil "mouseup" self up (mouse-control self)) (bwhen (clickee (mouse-control self)) (bwhen (upper (mouse-up-handler clickee)) - (trc "mouseup clickee, clickw" clickee self) + (trc nil "mouseup clickee, clickw" clickee self) (funcall upper clickee up)))))
(defparameter *gw* nil) --- /project/cello/cvsroot/cello/mouse-click.lisp 2006/10/02 02:59:18 1.6 +++ /project/cello/cvsroot/cello/mouse-click.lisp 2006/10/13 05:57:27 1.7 @@ -30,7 +30,8 @@ :documentation "Unreliable unless click-repeat-p forcing events") (click-completed :reader click-completed :initform (c? (when (typep (click-window self) 'model) ;; <- acl used to turn windows into - (mouse-up-evt (click-window self))))) ;; closed-stream instances + (eko (nil "click-completed" (click-window self)) + (mouse-up-evt (click-window self)))))) ;; closed-stream instances
(click-over :reader click-over :initform (c? (when (typep (click-window self) 'model) @@ -45,11 +46,11 @@ (mouse-pos (click-window self)))))))
(clicked :reader clicked - :initform (c? (trc "clicked?> typeof clickw" (click-window self) (type-of (click-window self))) + :initform (c? (trc nil "clicked?> typeof clickw" (click-window self) (type-of (click-window self))) (when (typep (click-window self) 'model) - (trc "clicked?> asking clickcompleted") + (trc nil "clicked?> asking clickcompleted") (bwhen (up (^click-completed)) - (trc "clicked?> asking point-in-box" + (trc nil "clicked?> asking point-in-box" (evt-where up) (clickee self) (without-c-dependency @@ -60,7 +61,8 @@ (cons (clickee self) up)))))) ) (:default-initargs - :expiration (c? (mouse-up-evt (click-window self))))) + :expiration (c? (eko (nil "expiry?" (click-window self)) + (mouse-up-evt (click-window self))))))
(defmethod initialize-instance :after ((self mouse-click) &key) (with-integrity (:change :ii-mouseclick) @@ -69,7 +71,7 @@ (focus-navigate (focus (click-window self)) (clickee self))))
;;;20060601 (to-be self) ;; unnecessary? 2301kt just moved this from after next line - (trc "echo click set self clickee" self (clickee self)) + (trc nil "echo click set self clickee" self (clickee self))
(when (clickee self) (setf (click-evt (clickee self)) self)))) @@ -91,18 +93,19 @@ (declare (ignorable other click)))
(defmethod not-to-be :around ((self mouse-click)) - (when (typep (click-window self) 'window) ;; /// why worry about this? - (trc "echo click clearing self from clickee" (clickee self)) - (setf (click-evt (clickee self)) nil) ;; do this first? - ;; (trc "echo click not-to-be-ing self from clickee" self) - (call-next-method) - (set-doubleclick? (click-window self) self) ;; from Win32 days - )) + (when (typep (click-window self) 'model) ;; ACL can do weird things closing a window + (with-integrity (:change :not-to-be-click) + (trc nil "echo click clearing self from clickee" (clickee self)) + (setf (click-evt (clickee self)) nil) ;; do this first? + ;; (trc "echo click not-to-be-ing self from clickee" self) + (call-next-method) + (set-doubleclick? (click-window self) self) ;; from Win32 days + )))
(defobserver clicked () - (trc "echo clicked " self new-value) + (trc nil "echo clicked " self new-value) (when (and new-value (click-window self)) - (trc "echo clicked calling control-do-action" self new-value) + (trc nil "echo clicked calling control-do-action" self new-value) (control-do-action (car new-value) (cdr new-value))))
;----------------------------------------