diff options
| -rw-r--r-- | examples/02-moving-bitmp.lisp | 30 | ||||
| -rw-r--r-- | wheelwork.lisp | 156 |
2 files changed, 135 insertions, 51 deletions
diff --git a/examples/02-moving-bitmp.lisp b/examples/02-moving-bitmp.lisp index 5d33de8..200a1d1 100644 --- a/examples/02-moving-bitmp.lisp +++ b/examples/02-moving-bitmp.lisp @@ -9,28 +9,28 @@ (defclass bitmap-display (ww::application ) ()) (ww::defhandler move-thing - (ww::on-keydown (unit code mods) - (case code - (:scancode-left (decf (ww::unit-x unit) (ww::unit-width unit))) - (:scancode-right (incf (ww::unit-x unit) (ww::unit-width unit))) - (:scancode-down (decf (ww::unit-y unit) (ww::unit-height unit))) - (:scancode-up (incf (ww::unit-y unit) (ww::unit-height unit))) + (ww::on-keydown () + (case scancode + (:scancode-left (decf (ww::unit-x target) (ww::unit-width target))) + (:scancode-right (incf (ww::unit-x target) (ww::unit-width target))) + (:scancode-down (decf (ww::unit-y target) (ww::unit-height target))) + (:scancode-up (incf (ww::unit-y target) (ww::unit-height target))) (:scancode-equals - (when (or (member :lshift mods) (member :rshift mods)) - (incf (ww::unit-height unit) 20.0) - (incf (ww::unit-width unit) 20.0))) + (when (or (member :lshift modifiers) (member :rshift modifiers)) + (incf (ww::unit-height target) 20.0) + (incf (ww::unit-width target) 20.0))) (:scancode-minus - (decf (ww::unit-height unit) 20.0) - (decf (ww::unit-width unit) 20.0))) + (decf (ww::unit-height target) 20.0) + (decf (ww::unit-width target) 20.0))) (format t "ghoul pos: ~a,~a~%" - (ww::unit-x unit) (ww::unit-y unit)))) + (ww::unit-x target) (ww::unit-y target)))) (ww::defhandler thing-clicked - (ww::on-mousedown (unit x y clicks button) - (format t "~a was clicked at ~a,~a!~%" unit x y))) + (ww::on-mousedown () + (format t "~a was clicked at ~a,~a!~%" target x y))) (ww::defhandler mouse-over - (ww::on-mousemotion (target x y xrel yrel state) + (ww::on-mousemotion () (print (list target x y xrel yrel state)))) (defmethod ww::boot ((app bitmap-display)) 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))) |