Update of /project/cello/cvsroot/cello In directory clnet:/tmp/cvs-serv9119

Modified Files: cello-magick.lisp cello-window.lisp control.lisp ctl-selectable.lisp ctl-toggle.lisp focus-navigation.lisp focus-utilities.lisp focus.lisp image.lisp ix-styled.lisp ix-text.lisp ix-togl.lisp lighting.lisp mouse-click.lisp window-utilities.lisp wm-mouse.lisp Log Message: nothing special

--- /project/cello/cvsroot/cello/cello-magick.lisp 2007/02/02 20:11:00 1.7 +++ /project/cello/cvsroot/cello/cello-magick.lisp 2008/06/16 12:39:20 1.8 @@ -53,6 +53,8 @@ (ogl::glec :snapshot) (record-frame recording pixels columns rows))))

+(export! ix-image-file) + (defmd ix-image-file (ix-view) (:documentation "Quick way to drop a view of a binary JPG, PNG, GIF, etc into a Cello window") image-path --- /project/cello/cvsroot/cello/cello-window.lisp 2008/04/11 09:22:46 1.8 +++ /project/cello/cvsroot/cello/cello-window.lisp 2008/06/16 12:39:20 1.9 @@ -33,6 +33,7 @@ :lb (c-in (scr2log -800)) ;; :tick-count (c-in (os-tickcount)) :event-handler 'cello-window-event-handler + :registry? t ))

(defmethod path ((self cello-window)) ".") --- /project/cello/cvsroot/cello/control.lisp 2008/04/11 09:22:46 1.10 +++ /project/cello/cvsroot/cello/control.lisp 2008/06/16 12:39:20 1.11 @@ -15,7 +15,7 @@ |#

(in-package :cello) -(export! control enabled ^enabled ct-action-lambda +(export! control enabled ^enabled ct-action-lambda sound ^sound tool-tip tool-tip-show? click-evt ^click-evt ^mouse-over? mouse-over?)

(defmd control () @@ -26,12 +26,11 @@ (ct-action nil :cell nil) sound click-repeat-p - #+hunh? (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)) + (double-click-evt (c-in nil)) + (double-click-action (c-in nil)) (click-tolerance (mkv2 0 0) :cell nil) (key-evt nil :cell :ephemeral) (enabled t) @@ -49,6 +48,17 @@

(defmethod user-errors (other) (declare (ignore other)))

+(defmethod do-double-click ((self control) ) + (b-when a (^double-click-action) + (trc "control sees defmethod" self a) + (funcall a self) + t)) ;; ie, handled + +(export! control-trigger) +(defun control-trigger (self &key even-if-disabled) + (when (or even-if-disabled (^enabled)) + (funcall (ct-action self) self nil))) + (defmethod tool-tip-show? (other) (declare (ignore other)) nil) @@ -65,12 +75,6 @@

(defmethod kb-selector (other) (declare (ignore other)) nil)

-(defobserver click-repeat-event () - (with-integrity (:change :obs-click-repeat-event) - (when new-value - (bwhen (f (ct-action self)) - (funcall f self (os-event (^click-evt))))))) ;; /// make fresh event with new time - (defmethod enabled (other)(assert other) nil)

(defmethod do-cello-keydown ((self control) k event) --- /project/cello/cvsroot/cello/ctl-selectable.lisp 2008/04/11 09:22:47 1.5 +++ /project/cello/cvsroot/cello/ctl-selectable.lisp 2008/06/16 12:39:20 1.6 @@ -31,9 +31,10 @@

(defmd ct-selector-ex (ct-selector) ;; mixin at any node containing ct.selectable.ex's (selected-key (c-in nil)) - :selection (c? (let (sel) + :selection (c? (ekx new-seletcion!!!!!! + let (sel) (bwhen (skey (^selected-key)) - ;(trc "sel rule runs" self skey .cache) + (trc "sel rule runs" self skey .cache) (fm-traverse self (lambda (node) (when (typep node 'ct-selectable-ex) @@ -113,7 +114,7 @@ (defmd ct-selectable-ex (control) (selected-key (c-in nil)) (selectedp (c? (bwhen (selector (ct-selector self)) - ;;(trc "selectable-ex selectedp sees" (selection selector)) + (trc "selectable-ex selectedp sees" self (^value) selector (selected-key selector) (selection selector)) (bwhen (skey (selected-key selector)) (eql (^selected-key) skey))))) :ct-action 'ct-selectable-ex-act) --- /project/cello/cvsroot/cello/ctl-toggle.lisp 2008/04/11 09:22:47 1.12 +++ /project/cello/cvsroot/cello/ctl-toggle.lisp 2008/06/16 12:39:20 1.13 @@ -93,7 +93,7 @@ :transition-fn 'ctfsm-transition-fn

:ct-action (ct-action-lambda - (trc "twister ct-action" self event) + ;(trc "twister ct-action" self event) (with-integrity (:change :ctfsm-action) (let ((newv (funcall (transition-fn self) self (value self) (states self)))) (ct-fsm-assume-value self newv)))))) --- /project/cello/cvsroot/cello/focus-navigation.lisp 2008/04/11 09:22:47 1.3 +++ /project/cello/cvsroot/cello/focus-navigation.lisp 2008/06/16 12:39:20 1.4 @@ -19,7 +19,7 @@ ;_____________________ N a v i g a t i o n ____________________ ; (defun focus-navigate (old new &optional leave-old) - #+xxx (trc "focus-navigate > old, new" old new) + #+x42 (trc "focus-navigate > old, new" old new) ;; (c-assert new) ;; 990810kt i don't remember if we navigate to nil (should tho) ///

(when (eql old new) --- /project/cello/cvsroot/cello/focus-utilities.lisp 2008/04/11 09:22:47 1.6 +++ /project/cello/cvsroot/cello/focus-utilities.lisp 2008/06/16 12:39:20 1.7 @@ -38,20 +38,26 @@ (focus-find-first self) (focus-find-first self :tab-stop-only nil)))

+(export! focus-on) + (defmethod focus-on (self &optional focuser) (c-assert (or self focuser)) #+xxx (trc "focus.on self, focuser" self focuser .focuser (focus-state .focuser)) ;; (break "focus.on self, focuser") (setf (focus (or focuser .focuser)) self))

-(defmethod focus-gain (self) - (declare (ignore self))) - -(defmethod focus-lose (self new-focus) - (if self - (focus-lose (fm-parent self) new-focus) - t) ;; means "yielded" - ) +(defgeneric focus-gain (self) + (:method (self) (declare (ignore self))) + (:method ((self focus)) (setf (^focused-on) t))) + +(defgeneric focus-lose (self new-focus) + (:method (self new-focus) (if self + (focus-lose (fm-parent self) new-focus) + t)) + (:method :around ((self focus) new-focus) + (declare (ignore new-focus)) + (when (call-next-method) + (setf (^focused-on) nil))))

;________________________________ I d l i n g _______________________ ; --- /project/cello/cvsroot/cello/focus.lisp 2008/04/11 09:22:47 1.7 +++ /project/cello/cvsroot/cello/focus.lisp 2008/06/16 12:39:20 1.8 @@ -22,10 +22,10 @@

;;; also got FFComposite rule deciding it was active if any kid was

-arrange for Focuser to process clicks and keys first, then mebbe dump into dvk, do-click/do-double-click +arrange for Focuser to process clicks and keys first, then mebbe dump into dvk, bottom up from focus/imageunder

-arrange for Controller to process clicks first, then mebbe dump into do-click/do-double-click +arrange for Controller to process clicks first, then mebbe dump into bottom up from focus/imageunder

add finalization for radio button (look at others, see if ICR can ne de-celled @@ -68,6 +68,8 @@ (focus-gain new-focus)) (call-next-method)))

+(export! focused-on ^focused-on) + (defmodel focus () ((focus-thickness :cell nil :initarg :focus-thickness :initform (u96ths 3) @@ -111,7 +113,9 @@

(defgeneric focus-handle-keysym (self keysym) (:method :around (self keysym) - (unless (call-next-method) + (progn ;; unless + (call-next-method) + ;; (trc "unhandled so parent?" .parent) (when .parent (focus-handle-keysym .parent keysym)))) (:method (self keysym) (declare (ignore self keysym)) nil)) --- /project/cello/cvsroot/cello/image.lisp 2008/04/11 09:22:47 1.19 +++ /project/cello/cvsroot/cello/image.lisp 2008/06/16 12:39:20 1.20 @@ -44,7 +44,7 @@ recording (snapshot-pathnamer nil :cell nil) (snapshot-release-id :initarg :snapshot-release-id - :initform (c-in nil) :accessor snapshot-release-id) + :initform nil #+please (c-in nil) :accessor snapshot-release-id) ps3 ; persistence

; cached calculations @@ -180,6 +180,7 @@ :fm-parent *parent* :kids (c? (the-kids ,@dd-kids))))

+(export! ix-kid-sized) (defmodel ix-kid-sized (geo-kid-sized ix-family)()) (defmodel ix-inline (geo-inline ix-view)()) (defobserver .kids ((self ix-inline)) @@ -349,7 +350,7 @@ (dbg-awake-num ap 'lb) ) #+nope (unless (>= (lb ap) (lt ap)) ;; this happens normally as structures get "collapsed" etc - (inspect ap) + (error 'x-systemfatal :app-func 'dbg-awake :error-text "Bottom less than top: self, lT, height, lB" :other-data (list ap (lt ap) (l-height ap) (lb ap)))) (call-next-method)) --- /project/cello/cvsroot/cello/ix-styled.lisp 2008/04/11 09:22:48 1.8 +++ /project/cello/cvsroot/cello/ix-styled.lisp 2008/06/16 12:39:20 1.9 @@ -50,6 +50,7 @@ `(call-with-styles (list ,@custom-styles) (lambda () ,@body)))

(defun call-with-styles (styles styled-fn) + (setf *styles* styles) ;; need when showing off from repl (let ((*styles* styles)) (funcall styled-fn)))

@@ -111,6 +112,7 @@ ;; until 2008-03-30 this next was only done for extruded case above (ix-string-width self (display-text$ self))) ;; ugh. make better. subclass must have display-text$

+(export! ix-string-width)

(defun ix-string-width (self string) (c-assert (s-canvas) () "~a not contained by any canvas" self) --- /project/cello/cvsroot/cello/ix-text.lisp 2008/04/11 09:22:48 1.12 +++ /project/cello/cvsroot/cello/ix-text.lisp 2008/06/16 12:39:21 1.13 @@ -138,6 +138,18 @@ (defun find-menu (id) (fm-find-one *menus* id :must-find t :skip-tree nil :global-search nil :test #'cells::true-that))

+(defun make-string-tool-tip (self s) + (make-kid 'ix-text + :inset 3 + :style-id :label + :pre-layer (with-layers + +yellow+ + :fill + (:frame-3d :edge-raised + :thickness 2) + +black+) + :text$ s)) + (defmd tool-tip (ix-stack) :visible (c? (^kids)) :kids (c? (the-kids @@ -145,16 +157,10 @@ (when (tool-tip-show? v) (typecase (tool-tip v) (null) - (string (make-kid 'ix-text - :inset 3 - :style-id :label - :pre-layer (with-layers +yellow+ :fill - (:frame-3d :edge-raised - :thickness 2) - +black+) - :text$ (tool-tip v))) + (string + (make-string-tool-tip self (tool-tip v))) (t (funcall (tool-tip v) self v))))))) - + ; ; tedious geometry stuff to keep tool tip ; visible yet not eclipsed by mouse pointer @@ -165,9 +171,10 @@ ((^visible) .retog. (or fixed (setf fixed - (if (> (+ 16 (v2-h mp) (l-width self)) (lr .og.)) - (px-maintain-pr (- (v2-h mp) 16)) - (+ 16 (v2-h mp)))))) + (let ((pref (+ 6 (v2-h mp)))) + (if (> (+ pref (l-width self)) (lr .og.)) ;; don't sail off to right of togl + (px-maintain-pr (lr .og.) #+hunh? (- (v2-h mp) 16)) + pref))))) (t (setf fixed nil)))))) :py (let (fixed) (c? (bwhen (mp (mouse-pos .og.)) @@ -176,5 +183,5 @@ .retog. (or fixed (setf fixed (min (- (lt .og.)(l-height self)) - (py-maintain-pb (v2-v mp)))))) + (+ 6 (py-maintain-pb (v2-v mp))))))) (t (setf fixed nil))))))) --- /project/cello/cvsroot/cello/ix-togl.lisp 2008/04/11 09:22:49 1.18 +++ /project/cello/cvsroot/cello/ix-togl.lisp 2008/06/16 12:39:21 1.19 @@ -35,7 +35,7 @@ (without-c-dependency (find-ix-under self pos))))))) (:documentation "Mixin to have mouse view tracked in a subtree of the window, mostly so other GUI layout can depend on -the sub-tree layout without creating a cyclic dependency, as would happen if the whole window were watched.")) +the sub-tree layout without creating a cyclic dependency, as would happen iof the whole window were watched."))

(defmd ix-togl (mouse-view-tracker #+not focuser ogl-lit-scene control ogl-shared-resource-tender togl ix-view) (redisplayp nil :cell nil) @@ -57,7 +57,7 @@

(mouse-up-evt (c-in nil) :cell :ephemeral) (mouse-down-evt (c-in nil) :cell :ephemeral) - ;; FNYI (double-click? (c-in nil)) + (double-click-evt (c-in nil) :cell :ephemeral)

(tick-count (c-in nil)) (tick-fine (c-in nil)) @@ -75,7 +75,14 @@ :cb-destroy (lambda (self) ;(trc "IX-TOGL being destoyed!!!!!!!!!!" self) (setf (togl-ptr self) nil) ;; new 2007-04-13 to avoid togl.c line 1039 crash closing window - (setf cells::*c-debug* t))) + ;; bad idea to do it this way, gotta get *istack* bound first: (setf cells::*c-debug* t) + )) + +(defmethod ctk::do-on-double-click-1 :before ((self ix-togl) &rest args) + (trc "IX-togl do-on-double-click-1 before" self (mouse-control self)) + (bif (mi (mouse-control self)) + (do-double-click mi ) + (do-double-click self )))

;;;(defobserver mouse-pos ((self ix-togl)) ;;; #+nah (when new-value @@ -125,26 +132,29 @@ (:KeyPress ) (:KeyRelease ) (:ButtonPress - (setf (mouse-pos self) (mkv2 (ctk::xbe-x xe) - (- (ctk::xbe-y xe)))) ; trigger mouseview recalc - (setf (mouse-down-evt self) (eko (nil "mousedown!!!" (ctk::xbe button xe)) - (make-os-event - :modifiers (keyboard-modifiers .tkw) - :where (mouse-pos self) - :realtime (now) - :c-event xe))) - (when (eql 3 (ctk::xbe button xe)) - (when (^mouse-view) - (inspect (^mouse-view))))) + (case (xbe-button xe) + (1 (setf (mouse-pos self) (mkv2 (xbe-x xe) + (- (xbe-y xe)))) ; trigger mouseview recalc + (setf (mouse-down-evt self) (eko (nil "mousedown!!!" (ctk::xbe button xe)) + (make-os-event + :modifiers (keyboard-modifiers .tkw) + :where (mouse-pos self) + :realtime (now) + :c-event xe)))) + (3 (when (^mouse-view) + (inspect (^mouse-view)))))) + (:ButtonRelease - (setf (mouse-pos self) (mkv2 (ctk::xbe-x xe) - (- (ctk::xbe-y xe)))) ; trigger mouseview recalc - (setf (mouse-up-evt self) (eko (nil "mouse up!!!") - (make-os-event - :modifiers (keyboard-modifiers .tkw) - :where (mouse-pos self) - :realtime (now) - :c-event xe)))) + (case (xbe-button xe) + (1 (setf (mouse-pos self) (mkv2 (ctk::xbe-x xe) + (- (ctk::xbe-y xe)))) ; trigger mouseview recalc + (with-metrics (nil nil "mouse up evt") + (setf (mouse-up-evt self) (eko (nil "mouse up!!!") + (make-os-event + :modifiers (keyboard-modifiers .tkw) + :where (mouse-pos self) + :realtime (now) + :c-event xe)))))))

(:MotionNotify (trc nil "setting mouse pos!!!!" (ctk::xbe-x xe) (- (ctk::xbe-y xe))) @@ -186,7 +196,6 @@ (dolist (light new-value) (md-awaken light)))

- (defmethod ogl-node-window ((self ix-togl)) self)

@@ -248,7 +257,7 @@ (defobserver mouse-down-evt (self m-down) .retog. (when m-down - #+xxx (trcx mousedown self m-down (mouse-control self)) + #+x (trcx 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 --- /project/cello/cvsroot/cello/lighting.lisp 2008/04/11 09:22:50 1.9 +++ /project/cello/cvsroot/cello/lighting.lisp 2008/06/16 12:39:21 1.10 @@ -92,7 +92,7 @@ (ix-render-light self)))) (loop for light in (fixed-lighting self) do (ix-render-light light)) - (when (and (not lights) (emergency-lighting self)) + (when (not lights) (dolist (e-light (emergency-lighting self)) (ix-render-light e-light)))))

--- /project/cello/cvsroot/cello/mouse-click.lisp 2008/04/11 09:22:50 1.9 +++ /project/cello/cvsroot/cello/mouse-click.lisp 2008/06/16 12:39:24 1.10 @@ -48,7 +48,7 @@ (mouse-pos (click-window self)))))))

(clicked :reader clicked - :initform (c? (trc nil "clicked?> typeof clickw" (click-window self) (type-of (click-window self))) + :initform (c? ;(trc "clicked?> typeof clickw" (click-window self) (type-of (click-window self))) (when (typep (click-window self) 'model) (trc nil "clicked?> asking clickcompleted") (bwhen (up (^click-completed)) --- /project/cello/cvsroot/cello/window-utilities.lisp 2008/04/11 09:22:50 1.10 +++ /project/cello/cvsroot/cello/window-utilities.lisp 2008/06/16 12:39:24 1.11 @@ -18,12 +18,12 @@

;-------------------- double click -----------------------------------

-(defmethod do-double-click :around (self os-event &rest iargs &key &allow-other-keys) +(defmethod do-double-click :around (self) (when self (or (call-next-method) - (apply #'do-double-click (fm-parent self) os-event iargs)))) + (do-double-click (fm-parent self)))))

-(defmethod do-double-click (self os-event &key) +(defmethod do-double-click (self) (declare (ignorable self os-event)) ;;(trc "*** No special do-double-click for ix-view, event:" self osEvent) nil) --- /project/cello/cvsroot/cello/wm-mouse.lisp 2006/11/04 20:56:30 1.6 +++ /project/cello/cvsroot/cello/wm-mouse.lisp 2008/06/16 12:39:24 1.7 @@ -16,21 +16,6 @@

(in-package :cello)

-(defmethod do-click :around (self os-event) - (declare (ignorable os-event)) - (when self - (or (call-next-method) - (do-click (fm-parent self) os-event)))) - -(defmethod do-click (self os-event) - (declare (ignorable self os-event)) - nil) - -; -; ------------ double click --------------------------------------- -; - - (defstruct (os-event (:conc-name nil)) modifiers