[cells-cvs] CVS Celtk

[fgoenninger]

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)