diff options
| -rw-r--r-- | examples/02-moving-bitmp.lisp | 5 | ||||
| -rw-r--r-- | wheelwork.lisp | 19 |
2 files changed, 19 insertions, 5 deletions
diff --git a/examples/02-moving-bitmp.lisp b/examples/02-moving-bitmp.lisp index a132e9f..153ca1d 100644 --- a/examples/02-moving-bitmp.lisp +++ b/examples/02-moving-bitmp.lisp @@ -75,6 +75,10 @@ (ww::on-blur () (format t "~a lost focus~%" target))) +(ww::defhandler wheelie + (ww::on-mousewheel () + (print (list :mousewheel horiz vert dir)))) + (defmethod ww::boot ((app bitmap-display)) (let ((bm (make-instance 'ww::bitmap @@ -95,6 +99,7 @@ (ww::set-handler bm2 #'thing-clicked) (ww::set-handler bm2 #'look-at-me ) (ww::set-handler bm2 #'look-away) + (ww::set-handler bm2 #'wheelie) (ww::add-unit app bm2))) diff --git a/wheelwork.lisp b/wheelwork.lisp index 1aefd51..d8637f1 100644 --- a/wheelwork.lisp +++ b/wheelwork.lisp @@ -405,6 +405,12 @@ give focus to whatever was clicked." (handler (get-handler-for target 'mousemotion))) (funcall handler target x y xrel yrel state wx wy wxrel wyrel)))))) +(defun eventloop-mousewheel (app wx wy dir) + (when (should-listen-for-p 'mousewheel app) + (when-let* ((focus (get-focus app)) + (handler (get-handler-for focus 'mousewheel))) + (funcall handler focus wx wy dir)))) + (defun eventloop (app) (sdl2:with-event-loop (:method :poll) (:mousebuttondown @@ -419,6 +425,9 @@ give focus to whatever was clicked." (:keyup (:keysym keysym) (eventloop-keyup app keysym)) + (:mousewheel + (:x x :y y :direction dir) + (eventloop-mousewheel app x y dir)) (:idle () (render app)) (:quit () t))) @@ -724,20 +733,20 @@ can be redefined using this form to support interactive development." ,@body))) (defmacro on-mousewheel - ((&optional (target 'target) (x 'x) (y 'y) (dir 'dir)) &body body) + ((&optional (target 'target) (horiz 'horiz) (vert 'vert) (dir 'dir)) &body body) "Creates a handler for MOUSEWHEEL events" `(make-instance 'event-handler :event-type 'wheelwork::mousewheel :handler-function (lambda (,(intern (symbol-name target)) - ,(intern (symbol-name x)) - ,(intern (symbol-name y)) + ,(intern (symbol-name horiz)) + ,(intern (symbol-name vert)) ,(intern (symbol-name dir))) (declare (ignorable ,(intern (symbol-name target)) - ,(intern (symbol-name x)) - ,(intern (symbol-name y)) + ,(intern (symbol-name horiz)) + ,(intern (symbol-name vert)) ,(intern (symbol-name dir)))) ,@body))) |