From fgoenninger at common-lisp.net Sun Jul 12 11:34:49 2009 From: fgoenninger at common-lisp.net (fgoenninger) Date: Sun, 12 Jul 2009 07:34:49 -0400 Subject: [cells-cvs] CVS Celtk Message-ID: Update of /project/cells/cvsroot/Celtk In directory cl-net:/tmp/cvs-serv29747 Modified Files: widget.lisp Log Message: Added: ON-HOVER functionality provided by Andy Chambers: The usage would be... (defmd my-window (window) :kids (c? (the-kids (mk-stack (:packing (c?pack-self)) (mk-label :text "hi" :on-hover (lambda () (trc "hovering..."))))))) The on-hover function only gets called after the mouse has been sitting in the widget for 1 1/2 seconds. Thanks again, Andy! Thanks again, Andy! --- /project/cells/cvsroot/Celtk/widget.lisp 2008/03/17 20:33:57 1.22 +++ /project/cells/cvsroot/Celtk/widget.lisp 2009/07/12 11:34:49 1.23 @@ -51,6 +51,7 @@ (return-from xwin-widget self)) finally (trc "xwin-widget > no widget for xwin " xwin))))) +widget-event-handle ;;; --- widget ----------------------------------------- (defmodel widget (family tk-object) @@ -138,7 +139,7 @@ (bif (self (tkwin-widget client-data)) (widget-event-handle self xe) ;; sometimes I hit the next branch restarting after crash.... - (trc nil "widget-event-handler > no widget for tkwin ~a" client-data)) + (trc "widget-event-handler > no widget for tkwin" (tkwin-widget client-data))) #+nahhh(handler-case (bif (self (tkwin-widget client-data)) (widget-event-handle self xe) @@ -176,24 +177,43 @@ (export! widget-event-handle) (defmethod widget-event-handle ((self widget) xe) ;; override for class-specific handling - (trc nil "bingo widget-event-handle" (xevent-type xe)) + (trc "bingo >>>>>>> widget-event-handle" (xevent-type xe)) (bif (h (^event-handler)) ;; support instance-specific handlers (funcall h self xe) (case (xevent-type xe) - (:buttonpress (trc "button pressed:" (xbe button xe)(xbe x xe)(xbe y xe)(xbe x-root xe)(xbe y-root xe))) - (:buttonrelease (trc "button released:" (xbe button xe)(xbe x xe)(xbe y xe)(xbe x-root xe)(xbe y-root xe)))(:MotionNotify - (xevent-dump xe)) + (:buttonpress + (trc "button pressed:" (xbe button xe)(xbe x xe)(xbe y xe)(xbe x-root xe)(xbe y-root xe))) + (:buttonrelease + (trc "button released:" (xbe button xe)(xbe x xe)(xbe y xe)(xbe x-root xe)(xbe y-root xe))) + (:MotionNotify (xevent-dump xe)) + (:EnterNotify (initiate-hover-event self)) + (:LeaveNotify (cancel-hover-event self)) (:virtualevent)))) +(defun initiate-hover-event (self) + (setf (hover-timer self) + (make-instance 'timer + :delay 1500 + :repeat (c-in 1) + :action (lambda (timer) + (declare (ignore timer) + (bif (fn (on-hover self)) + (funcall fn))))))) + +(defun cancel-hover-event (self) + (cancel-timer (hover-timer self))) + (defmethod tk-configure ((self widget) option value) (tk-format `(:configure ,self ,option) "~a configure ~(~a~) ~a" (path self) option (tk-send-value value))) - (defmethod not-to-be :after ((self widget)) - (when (or (and (eql self .tkw) (not (find .tkw *windows-destroyed*))) - (not (find .tkw *windows-being-destroyed*))) - (trc "not-to-be destroying widget" (^path)) - (break "not to be") + (trc nil "NOT-TO-BE :AFTER (self widget): .tkw | self -> " .tkw self) + (trc nil "NOT-TO-BE :AFTER (self widget): *windows-destroyed* -> " *windows-destroyed*) + (trc nil "NOT-TO-BE :AFTER (self widget): *windows-being-destroyed* -> " *windows-being-destroyed*) + (when (or (and (eql self .tkw) + (not (find .tkw *windows-destroyed*))) + (not (find .tkw *windows-being-destroyed*))) + (trc nil "not-to-be destroying widget" (^path)) (tk-format `(:forget ,self) "pack forget ~a" (^path)) (tk-format `(:destroy ,self) "destroy ~a" (^path)))) @@ -310,9 +330,6 @@ (tcl-set-var *tki* (tk-variable self) v$ (var-flags :tcl-namespace-only)))))) - - - ;;; --- menus --------------------------------- (defun pop-up (menu x y) From fgoenninger at common-lisp.net Sun Jul 12 11:36:19 2009 From: fgoenninger at common-lisp.net (fgoenninger) Date: Sun, 12 Jul 2009 07:36:19 -0400 Subject: [cells-cvs] CVS Celtk Message-ID: Update of /project/cells/cvsroot/Celtk In directory cl-net:/tmp/cvs-serv30167 Modified Files: tk-object.lisp Log Message: Added: ON-HOVER functionality provided by Andy Chambers. See file widget.lisp for explanation (CVS log of that file). --- /project/cells/cvsroot/Celtk/tk-object.lisp 2008/06/16 12:35:56 1.17 +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2009/07/12 11:36:15 1.18 @@ -24,14 +24,17 @@ (defmodel tk-object (model) ((.md-name :cell nil :initform (gentemp "TK") :initarg :id) (tk-class :cell nil :initform nil :initarg :tk-class :reader tk-class) - + (hover-timer :cell nil :initform nil :initarg :hover-timer :reader hover-timer) (timers :owning t :initarg :timers :accessor timers :initform nil) (on-command :initarg :on-command :accessor on-command :initform nil) + (on-hover :initarg :on-hover :accessor on-hover :initform nil) (on-key-down :initarg :on-key-down :accessor on-key-down :initform nil :documentation "Long story. Tcl C API weak for keypress events. This gets dispatched eventually thanks to DEFCOMMAND") (on-key-up :initarg :on-key-up :accessor on-key-up :initform nil) (on-double-click-1 :initarg :on-double-click-1 :accessor on-double-click-1 :initform nil) + (on-double-click-2 :initarg :on-double-click-2 :accessor on-double-click-2 :initform nil) + (on-double-click-3 :initarg :on-double-click-3 :accessor on-double-click-3 :initform nil) (user-errors :initarg :user-errors :accessor user-errors :initform nil) (tile? :initform t :cell nil :reader tile? :initarg :tile?)) From fgoenninger at common-lisp.net Sun Jul 12 14:47:46 2009 From: fgoenninger at common-lisp.net (fgoenninger) Date: Sun, 12 Jul 2009 10:47:46 -0400 Subject: [cells-cvs] CVS Celtk Message-ID: Update of /project/cells/cvsroot/Celtk In directory cl-net:/tmp/cvs-serv24299 Modified Files: widget.lisp Log Message: Fixed: incorrect patch import - leftover "widget-event-handle" removed. --- /project/cells/cvsroot/Celtk/widget.lisp 2009/07/12 11:34:49 1.23 +++ /project/cells/cvsroot/Celtk/widget.lisp 2009/07/12 14:47:46 1.24 @@ -51,7 +51,6 @@ (return-from xwin-widget self)) finally (trc "xwin-widget > no widget for xwin " xwin))))) -widget-event-handle ;;; --- widget ----------------------------------------- (defmodel widget (family tk-object)