[cello-cvs] CVS cello
ktilton
ktilton at common-lisp.net
Mon Jun 16 12:39:26 UTC 2008
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 , at 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 , at custom-styles) (lambda () , at 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
More information about the Cello-cvs
mailing list