On Sat, Jul 11, 2009 at 9:33 PM, Kenneth Tilton<kentil...@gmail.com> wrote:
> Andy,
>
> Please search on :motionnotify. I see an example in the gears demo. I know
> that is OpenGL but I am pretty sure all the code you see in there in re
> event handling is generic to Tk, nothing about OpenGl.
>
> The nise thing about Tk via FFI is the control one gets from low-level
> access to the event stream. There are rare cases where I feel Tk did not
> expose enough via an API -- I remember vaguely something about key events,
> forcing me to code up a virtual event handler -- but as a rule the Tcl/Tk
> world is your oyster with an FFI based interface.
Cool I've got something working. Just posting it to the list in-case
anyone else
wants to use it...
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. The attached patch puts an on-hover slot on
the widget
class so you should be able to apply to any widget in your hierarchy.
--
Andy
diff --git a/tk-object.lisp b/tk-object.lisp
index 3a90bf3..5ee978a 100644
--- a/tk-object.lisp
+++ b/tk-object.lisp
@@ -24,8 +24,10 @@ See the Lisp Lesser GNU Public License for more details.
(defmd tk-object ()
(.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")
diff --git a/widget.lisp b/widget.lisp
index bb5d366..2217494 100644
--- a/widget.lisp
+++ b/widget.lisp
@@ -45,6 +45,7 @@ See the Lisp Lesser GNU Public License for more details.
(return-from xwin-widget self))
finally (trc "xwin-widget > no widget for xwin " xwin)))))
+widget-event-handle
;;; --- widget -----------------------------------------
(defmd widget (family tk-object)
@@ -176,9 +177,34 @@ See the Lisp Lesser GNU Public License for more details.
(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
+ (: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))
- (:virtualevent))))
+ (:EnterNotify
+ (initiate-hover-event self))
+ (:LeaveNotify
+ (cancel-hover-event self))
+ (:virtualevent
+ (trc "detected virtual event...")))))
+
+
+(defun initiate-hover-event (self)
+ (trc "initiate hover event;")
+ (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))))))
+ ;; (declare (ignore timer))
+ ;; (funcall (on-hover self))))))
+
+(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)))
_______________________________________________
cells-devel site list
cells-devel@common-lisp.net
http://common-lisp.net/mailman/listinfo/cells-devel
