diff options
Diffstat (limited to 'wheelwork.lisp')
| -rw-r--r-- | wheelwork.lisp | 156 |
1 files changed, 120 insertions, 36 deletions
diff --git a/wheelwork.lisp b/wheelwork.lisp index 34efd3c..f742fdd 100644 --- a/wheelwork.lisp +++ b/wheelwork.lisp @@ -338,24 +338,25 @@ order). Makes sure to remove the unit from its current container if necessary." (with-slots (height scale) app (list (/ x scale) (/ (- height y) scale)))) -(defun eventloop-mousebuttondown (app x y clicks button) +(defun eventloop-mousebuttondown (app wx wy clicks button) "Searches for a handler to handle applies it if found. Additionally, if the APPLICATION's REFOCUS-ON-MOUSEDOWN-P is T, try to give focus to whatever was clicked." - (destructuring-bind (x y) (screen-to-world x y) + (destructuring-bind (x y) (screen-to-world wx wy) (when-let (target (unit-under app x y)) (when (refocus-on-mousedown-p app) (refocus-on target)) (when-let (handler (get-handler-for target 'mousedown)) - (funcall handler target x y clicks button))))) + (funcall handler target x y clicks button wx wy))))) -(defun eventloop-mousemotion (app x y xrel yrel state) +(defun eventloop-mousemotion (app wx wy wxrel wyrel state) (when (should-listen-for-p 'mousemotion app) - (destructuring-bind (x y) (screen-to-world x y) - (when-let* ((target (unit-under app x y)) - (handler (get-handler-for target 'mousemotion))) - (funcall handler target x y xrel yrel state))))) + (destructuring-bind (x y) (screen-to-world wx wy) + (destructuring-bind (xrel yrel) (screen-to-world wxrel wyrel) + (when-let* ((target (unit-under app x y)) + (handler (get-handler-for target 'mousemotion))) + (funcall handler target x y xrel yrel state wx wy wxrel wyrel)))))) (defun eventloop (app) (sdl2:with-event-loop (:method :poll) @@ -528,18 +529,19 @@ disk." (setf (fdefinition ',name) ,handler-var))))) - (defmacro on-perframe - ((target time) &body body) + ((&optional (target 'target) (time 'time)) &body body) `(make-instance 'event-handler :event-type 'wheelwork::perframe - :handler-function (lambda (,target ,time) - (declare (ignorable ,target ,time)) + :handler-function (lambda (,(intern (symbol-name target)) + ,(intern (symbol-name time))) + (declare (ignorable ,(intern (symbol-name target)) + ,(time (intern (symbol-name time))))) ,@body))) (defmacro on-keydown - ((target scancode modifiers) &body body) + ((&optional (target 'target) (scancode 'scancode) (modifiers 'modifiers)) &body body) "Creates a lambda suitable for the value of a keydown event handler. The function accepts two positional arguments TARGET and SCANCODE and one &REST argument MODIFIERS. @@ -550,11 +552,16 @@ disk." `(make-instance 'event-handler :event-type 'wheelwork::keydown - :handler-function (lambda (,target ,scancode &rest ,modifiers) - (declare (ignorable ,target ,scancode ,modifiers)) + :handler-function (lambda (,(intern (symbol-name target)) + ,(intern (symbol-name scancode)) + &rest ,(intern (symbol-name modifiers))) + (declare (ignorable ,(intern (symbol-name target)) + ,(intern (symbol-name scancode)) + ,(intern (symbol-name modifiers)))) ,@body))) -(defmacro on-keyup ((target scancode modifiers) &body body) +(defmacro on-keyup + ((&optional (target 'target) (scancode 'scancode) (modifiers 'modifiers)) &body body) "Creates a lambda suitable for the value of a keyup event handler. The function accepts two positional arguments TARGET and SCANCODE and one &REST argument MODIFIERS. @@ -565,60 +572,137 @@ disk." `(make-instance 'event-handler :event-type 'wheelwork::keyup - :handler-function (lambda (,target ,scancode &rest ,modifiers) - (declare (ignorable ,target ,scancode ,modifiers)) + :handler-function (lambda (,(intern (symbol-name target)) + ,(intern (symbol-name scancode)) + &rest ,(intern (symbol-name modifiers))) + (declare (ignorable ,(intern (symbol-name target)) + ,(intern (symbol-name scancode)) + ,(intern (symbol-name modifiers)))) ,@body))) (defmacro on-mousemotion - ((target x y xrel yrel state) &body body) + ((&optional + (target 'target) + (x 'x) (y 'y) + (xrel 'xrel) (yrel 'yrel) + (state 'state) + (win-x 'win-x) (win-y 'win-y) + (win-xrel 'win-xrel) (win-yrel 'win-yrel)) + &body body) `(make-instance 'event-handler :event-type 'wheelwork::mousemotion - :handler-function (lambda (,target ,x ,y ,xrel ,yrel ,state) - (declare (ignorable ,target ,x ,y ,xrel ,yrel ,state)) + :handler-function (lambda (,(intern (symbol-name target)) + ,(intern (symbol-name x)) + ,(intern (symbol-name y)) + ,(intern (symbol-name xrel)) + ,(intern (symbol-name yrel)) + ,(intern (symbol-name state)) + ,(intern (symbol-name win-x)) + ,(intern (symbol-name win-y)) + ,(intern (symbol-name win-xrel)) + ,(intern (symbol-name win-yrel))) + (declare (ignorable ,(intern (symbol-name target)) + ,(intern (symbol-name x)) + ,(intern (symbol-name y)) + ,(intern (symbol-name xrel)) + ,(intern (symbol-name yrel)) + ,(intern (symbol-name state)) + ,(intern (symbol-name win-x)) + ,(intern (symbol-name win-y)) + ,(intern (symbol-name win-xrel)) + ,(intern (symbol-name win-yrel)))) ,@body))) (defmacro on-mousedown - ((target x y clicks button) &body body) + ((&optional (target 'target) + (x 'x) (y 'y) + (clicks 'clicks) (button 'button) + (win-x 'win-x) (win-y 'win-y)) + &body body) `(make-instance 'event-handler :event-type 'wheelwork::mousedown - :handler-function (lambda (,target ,x ,y ,clicks ,button) - (declare (ignorable ,target ,x ,y ,clicks ,button)) + :handler-function (lambda + (,(intern (symbol-name target)) + ,(intern (symbol-name x)) + ,(intern (symbol-name y)) + ,(intern (symbol-name clicks)) + ,(intern (symbol-name button)) + ,(intern (symbol-name win-x)) + ,(intern (symbol-name win-y))) + (declare + (ignorable ,(intern (symbol-name target)) + ,(intern (symbol-name x)) + ,(intern (symbol-name y)) + ,(intern (symbol-name clicks)) + ,(intern (symbol-name button)) + ,(intern (symbol-name win-x)) + ,(intern (symbol-name win-y)))) ,@body))) (defmacro on-mouseup - ((target x y clicks button) &body body) + ((&optional (target 'target) + (x 'x) (y 'y) + (clicks 'clicks) (button 'button) + (win-x 'win-x) (win-y 'win-y)) + &body body) `(make-instance 'event-handler :event-type 'wheelwork::mouseup - :handler-function (lambda (,target ,x ,y ,clicks ,button) - (declare (ignorable ,target ,x ,y ,clicks ,button)) + :handler-function (lambda + (,(intern (symbol-name target)) + ,(intern (symbol-name x)) + ,(intern (symbol-name y)) + ,(intern (symbol-name clicks)) + ,(intern (symbol-name button)) + ,(intern (symbol-name win-x)) + ,(intern (symbol-name win-y))) + (declare + (ignorable ,(intern (symbol-name target)) + ,(intern (symbol-name x)) + ,(intern (symbol-name y)) + ,(intern (symbol-name clicks)) + ,(intern (symbol-name button)) + ,(intern (symbol-name win-x)) + ,(intern (symbol-name win-y)))) ,@body))) (defmacro on-mousewheel - ((target x y dir) &body body) + ((&optional (target 'target) (x 'x) (y 'y) (dir 'dir)) &body body) `(make-instance 'event-handler :event-type 'wheelwork::mousewheel - :handler-function (lambda (,target ,x ,y ,dir) - (declare (ignorable ,target ,x ,y ,dir)) + :handler-function (lambda + (,(intern (symbol-name target)) + ,(intern (symbol-name x)) + ,(intern (symbol-name y)) + ,(intern (symbol-name dir))) + (declare + (ignorable ,(intern (symbol-name target)) + ,(intern (symbol-name x)) + ,(intern (symbol-name y)) + ,(intern (symbol-name dir)))) ,@body))) (defmacro on-blur - ((target) &body body) + ((&optional (target 'target)) &body body) `(make-instance 'event-handler :event-type 'wheelwork::blur - :handler-function (lambda (,target) - (declare (ignorable ,target)) + :handler-function (lambda + (,(intern (symbol-name target))) + (declare + (ignorable ,(intern (symbol-name target)))) ,@body))) (defmacro on-focus - ((target) &body body) + ((&optional (target 'target)) &body body) `(make-instance 'event-handler :event-type 'wheelwork::focus - :handler-function (lambda (,target) - (declare (ignorable ,target)) + :handler-function (lambda + (,(intern (symbol-name target))) + (declare + (ignorable ,(intern (symbol-name target)))) ,@body))) |