From 36e2bd0d18b5f1af6fd293168dc21e3f30caac91 Mon Sep 17 00:00:00 2001
From: Aethor <oow.autre@gmail.com>
Date: Mon, 3 Mar 2025 11:15:39 +0100
Subject: [PATCH] Add ability to handle wheel events with clog:set-on-wheel

---
 source/clog-base.lisp | 37 +++++++++++++++++++++++++++++++++++++
 source/clog.lisp      |  1 +
 test/test-clog.lisp   |  6 ++++++
 3 files changed, 44 insertions(+)

diff --git a/source/clog-base.lisp b/source/clog-base.lisp
index a677d38..dee8763 100644
--- a/source/clog-base.lisp
+++ b/source/clog-base.lisp
@@ -347,6 +347,24 @@ result or if time out DEFAULT-ANSWER. see JQUERY-QUERY (Internal)"))
       :meta-key     (js-true-p (nth 6 f))
       :drag-data    (quri:url-decode (or (nth 7 f) "")))))
 
+;;;;;;;;;;;;;;;;;;;;;;;
+;; parse-wheel-event ;;
+;;;;;;;;;;;;;;;;;;;;;;;
+
+(defparameter wheel-event-script
+  "+ e.originalEvent.deltaX + ':' + e.originalEvent.deltaY + ':' + e.originalEvent.deltaZ +
+':' + e.originalEvent.deltaMode"
+  "JavaScript to collect wheel event data from browser.")
+
+(defun parse-wheel-event (data)
+  (let ((f (ppcre:split ":" data)))
+    (list
+     :event-type :wheel
+     :delta-x (js-to-float (nth 0 f))
+     :delta-y (js-to-float (nth 1 f))
+     :delta-z (js-to-float (nth 2 f))
+     :delta-mode (js-to-integer (nth 3 f)))))
+
 ;;;;;;;;;;;;;;;
 ;; set-event ;;
 ;;;;;;;;;;;;;;;
@@ -1062,6 +1080,25 @@ ON-MOUSE-MOVE-HANDLER is nil unbind the event."))
              :cancel-event cancel-event
              :call-back-script mouse-event-script))
 
+;;;;;;;;;;;;;;;;;;
+;; set-on-wheel ;;
+;;;;;;;;;;;;;;;;;;
+
+(defgeneric set-on-wheel (clog-obj on-wheel-handler
+			  &key one-time cancel-event)
+  (:documentation "Set the ON-WHEEL-HANDLER for CLOG-OBJ. If
+ON-WHEEL-HANDLER is nil unbind the event."))
+
+(defmethod set-on-wheel ((obj clog-obj) handler
+			 &key (one-time nil) (cancel-event nil))
+  (set-event obj "wheel"
+	     (when handler
+	       (lambda (data)
+		 (funcall handler obj (parse-wheel-event data))))
+	     :one-time one-time
+	     :cancel-event cancel-event
+	     :call-back-script wheel-event-script))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; set-on-pointer-enter ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;
diff --git a/source/clog.lisp b/source/clog.lisp
index c8d4b34..cb75a0f 100644
--- a/source/clog.lisp
+++ b/source/clog.lisp
@@ -191,6 +191,7 @@ embedded in a native template application.)"
   (set-on-mouse-down         generic-function)
   (set-on-mouse-up           generic-function)
   (set-on-mouse-move         generic-function)
+  (set-on-wheel              generic-function)
   (set-on-pointer-enter      generic-function)
   (set-on-pointer-leave      generic-function)
   (set-on-pointer-over       generic-function)
diff --git a/test/test-clog.lisp b/test/test-clog.lisp
index 6ff45df..bd6d210 100644
--- a/test/test-clog.lisp
+++ b/test/test-clog.lisp
@@ -45,6 +45,12 @@
                        (lambda (obj data)
                          (declare (ignore obj))
                          (format t "x=~A Y=~A~%" (getf data ':x) (getf data ':y))))
+    (set-on-wheel *last-obj*
+		  (lambda (obj data)
+		    (declare (ignore obj))
+		    (format t "delta-x=~A delta-y=~A~%"
+			    (getf data ':delta-x)
+			    (getf data ':delta-y))))
     (set-on-key-down win
                       (lambda (obj data)
                         (declare (ignore obj))