diff --git a/clog-base.lisp b/clog-base.lisp index d07c844..427442b 100644 --- a/clog-base.lisp +++ b/clog-base.lisp @@ -223,6 +223,31 @@ result or if time out DEFAULT-ANSWER (Private)")) :shift-key (js-true-p (nth 7 f)) :meta-key (js-true-p (nth 8 f))))) +;;;;;;;;;;;;;;;;;;;;;;;;; +;; parse-pointer-event ;; +;;;;;;;;;;;;;;;;;;;;;;;;; + +(defparameter pointer-event-script + "+ (e.clientX - e.target.getBoundingClientRect().left) + ':' + + (e.clientY - e.target.getBoundingClientRect().top) + ':' + + e.screenX + ':' + e.screenY + ':' + e.which + ':' + e.altKey + ':' + + e.ctrlKey + ':' + e.shiftKey + ':' + e.metaKey" + "JavaScript to collect pointer event data from browser.") + +(defun parse-pointer-event (data) + (let ((f (ppcre:split ":" data))) + (list + :event-type :pointer + :x (parse-integer (nth 0 f) :junk-allowed t) + :y (parse-integer (nth 1 f) :junk-allowed t) + :screen-x (parse-integer (nth 2 f) :junk-allowed t) + :screen-y (parse-integer (nth 3 f) :junk-allowed t) + :which-button (parse-integer (nth 4 f) :junk-allowed t) + :alt-key (js-true-p (nth 5 f)) + :ctrl-key (js-true-p (nth 6 f)) + :shift-key (js-true-p (nth 7 f)) + :meta-key (js-true-p (nth 8 f))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;; ;; parse-keyboard-event ;; ;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -256,7 +281,7 @@ result or if time out DEFAULT-ANSWER (Private)")) (defun parse-drop-event (data) (let ((f (ppcre:split ":" data))) (list - :event-type :mouse + :event-type :drop :x (parse-integer (nth 0 f) :junk-allowed t) :y (parse-integer (nth 1 f) :junk-allowed t) :drag-data (quri:url-decode (or (nth 2 f) ""))))) @@ -272,15 +297,17 @@ result or if time out DEFAULT-ANSWER (Private)")) (defmethod set-event ((obj clog-obj) event handler &key (call-back-script "") (eval-script "") + (post-eval "") (cancel-event nil) (one-time nil)) (let ((hook (format nil "~A:~A" (html-id obj) event))) (cond (handler (bind-event-script - obj event (format nil "~Aws.send('E:~A '~A)~A~A" + obj event (format nil "~Aws.send('E:~A '~A)~A~A~A" eval-script hook call-back-script + post-eval (if one-time (format nil "; ~A.off('~A')" (jquery obj) @@ -899,6 +926,119 @@ ON-MOUSE-MOVE-HANDLER is nil unbind the event.")) (funcall handler obj (parse-mouse-event data)))) :call-back-script mouse-event-script)) +;;;;;;;;;;;;;;;;;;;;;;;;;; +;; set-on-pointer-enter ;; +;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric set-on-pointer-enter (clog-obj on-pointer-enter-handler) + (:documentation "Set the ON-POINTER-ENTER-HANDLER for CLOG-OBJ. If ON-POINTER-ENTER-HANDLER +is nil unbind the event.")) + +(defmethod set-on-pointer-enter ((obj clog-obj) handler) + (set-event obj "pointerenter" + (when handler + (lambda (data) + (declare (ignore data)) + (funcall handler obj))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;; +;; set-on-pointer-leave ;; +;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric set-on-pointer-leave (clog-obj on-pointer-leave-handler) + (:documentation "Set the ON-POINTER-LEAVE-HANDLER for CLOG-OBJ. If ON-POINTER-LEAVE-HANDLER +is nil unbind the event.")) + +(defmethod set-on-pointer-leave ((obj clog-obj) handler) + (set-event obj "pointerleave" + (when handler + (lambda (data) + (declare (ignore data)) + (funcall handler obj))))) + +;;;;;;;;;;;;;;;;;;;;;;;;; +;; set-on-pointer-over ;; +;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric set-on-pointer-over (clog-obj on-pointer-over-handler) + (:documentation "Set the ON-POINTER-OVER-HANDLER for CLOG-OBJ. If ON-POINTER-OVER-HANDLER +is nil unbind the event.")) + +(defmethod set-on-pointer-over ((obj clog-obj) handler) + (set-event obj "pointerover" + (when handler + (lambda (data) + (declare (ignore data)) + (funcall handler obj))))) + +;;;;;;;;;;;;;;;;;;;;;;;; +;; set-on-pointer-out ;; +;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric set-on-pointer-out (clog-obj on-pointer-out-handler) + (:documentation "Set the ON-POINTER-OUT-HANDLER for CLOG-OBJ. If ON-POINTER-OUT-HANDLER +is nil unbind the event.")) + +(defmethod set-on-pointer-out ((obj clog-obj) handler) + (set-event obj "pointerout" + (when handler + (lambda (data) + (declare (ignore data)) + (funcall handler obj))))) + +;;;;;;;;;;;;;;;;;;;;;;;;; +;; set-on-pointer-down ;; +;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric set-on-pointer-down (clog-obj on-pointer-down-handler + &key capture-pointer) + (:documentation "Set the ON-POINTER-DOWN-HANDLER for CLOG-OBJ. If +ON-POINTER-DOWN-HANDLER is nil unbind the event.")) + +(defmethod set-on-pointer-down ((obj clog-obj) handler + &key (capture-pointer nil)) + (set-event obj "pointerdown" + (when handler + (lambda (data) + (funcall handler obj (parse-pointer-event data)))) + :post-eval (if capture-pointer + (format nil "; ~A.setPointerCapture(e.pointerId)" + (script-id obj)) + "") + :call-back-script pointer-event-script)) + +;;;;;;;;;;;;;;;;;;;;;;; +;; set-on-pointer-up ;; +;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric set-on-pointer-up (clog-obj on-pointer-up-handler) + (:documentation "Set the ON-POINTER-UP-HANDLER for CLOG-OBJ. If +ON-POINTER-UP-HANDLER is nil unbind the event.")) + +(defmethod set-on-pointer-up ((obj clog-obj) handler) + (set-event obj "pointerup" + (when handler + (lambda (data) + (funcall handler obj (parse-pointer-event data)))) + :post-eval (format nil "; ~A.releasePointerCapture(e.pointerId)" + (script-id obj)) + :call-back-script pointer-event-script)) + +;;;;;;;;;;;;;;;;;;;;;;;;; +;; set-on-pointer-move ;; +;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric set-on-pointer-move (clog-obj on-pointer-move-handler) + (:documentation "Set the ON-POINTER-MOVE-HANDLER for CLOG-OBJ. If +ON-POINTER-MOVE-HANDLER is nil unbind the event.")) + +(defmethod set-on-pointer-move ((obj clog-obj) handler) + (set-event obj "pointermove" + (when handler + (lambda (data) + (funcall handler obj (parse-pointer-event data)))) + :call-back-script pointer-event-script)) + ;;;;;;;;;;;;;;;;;;;;;;;; ;; set-on-touch-start ;; ;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/clog.lisp b/clog.lisp index 091c026..5792c3d 100644 --- a/clog.lisp +++ b/clog.lisp @@ -131,6 +131,13 @@ 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-pointer-enter generic-function) + (set-on-pointer-leave generic-function) + (set-on-pointer-over generic-function) + (set-on-pointer-out generic-function) + (set-on-pointer-down generic-function) + (set-on-pointer-up generic-function) + (set-on-pointer-move generic-function) (set-on-touch-start generic-function) (set-on-touch-move generic-function) (set-on-touch-end generic-function) diff --git a/demos/03-demo.lisp b/demos/03-demo.lisp index 8b5364b..4a78dc5 100644 --- a/demos/03-demo.lisp +++ b/demos/03-demo.lisp @@ -11,43 +11,37 @@ (drag-mutex :reader drag-mutex :initform (bordeaux-threads:make-lock) - :documentation "Serialize access to the on-mouse-down event.") + :documentation "Serialize access to the on-ide-drag-down event.") (in-drag :accessor in-drag-p :initform nil :documentation "Ensure only one box is dragged at a time.") (drag-x :accessor drag-x - :documentation "The location of the left side of the box relative to mouse during drag.") + :documentation "The location of the left side of the box relative to pointer during drag.") (drag-y :accessor drag-y - :documentation "The location of the top of the box relative to mouse during drag."))) + :documentation "The location of the top of the box relative to pointer during drag."))) -(defun on-mouse-down (obj data) +(defun on-ide-drag-down (obj data) (let ((app (connection-data-item obj "app-data"))) (bordeaux-threads:with-lock-held ((drag-mutex app)) (unless (in-drag-p app) (setf (in-drag-p app) t) (let* ((id-drag (attribute obj "data-drag-obj")) (drag-obj (attach-as-child obj id-drag)) - (mouse-x (getf data ':screen-x)) - (mouse-y (getf data ':screen-y)) + (pointer-x (getf data ':screen-x)) + (pointer-y (getf data ':screen-y)) (obj-top (parse-integer (top drag-obj) :junk-allowed t)) (obj-left (parse-integer (left drag-obj) :junk-allowed t))) (setf (z-index drag-obj) 1) - (setf (drag-x app) (- mouse-x obj-left)) - (setf (drag-y app) (- mouse-y obj-top)) - (if (eq (getf data ':event-type) :touch) - (progn - (set-on-touch-move obj 'on-mouse-move) - (set-on-touch-end obj 'stop-obj-grab) - (set-on-touch-cancel obj 'on-mouse-leave)) - (progn - (set-on-mouse-move obj 'on-mouse-move) - (set-on-mouse-up obj 'stop-obj-grab) - (set-on-mouse-leave obj 'on-mouse-leave)))))))) + (setf (drag-x app) (- pointer-x obj-left)) + (setf (drag-y app) (- pointer-y obj-top)) + (set-on-pointer-move obj 'on-ide-drag-move) + (set-on-pointer-up obj 'stop-ide-drag) + (set-on-pointer-leave obj 'on-ide-drag-leave)))))) -(defun on-mouse-move (obj data) +(defun on-ide-drag-move (obj data) (let* ((app (connection-data-item obj "app-data")) (drag-obj (attach-as-child obj (attribute obj "data-drag-obj"))) (x (getf data ':screen-x)) @@ -55,19 +49,16 @@ (setf (top drag-obj) (format nil "~Apx" (- y (drag-y app)))) (setf (left drag-obj) (format nil "~Apx" (- x (drag-x app)))))) -(defun on-mouse-leave (obj) +(defun on-ide-drag-leave (obj) (let ((app (connection-data-item obj "app-data"))) (setf (in-drag-p app) nil) - (set-on-touch-move obj nil) - (set-on-touch-end obj nil) - (set-on-touch-cancel obj nil) - (set-on-mouse-move obj nil) - (set-on-mouse-up obj nil) - (set-on-mouse-leave obj nil))) + (set-on-pointer-move obj nil) + (set-on-pointer-up obj nil) + (set-on-pointer-leave obj nil))) -(defun stop-obj-grab (obj data) - (on-mouse-move obj data) - (on-mouse-leave obj)) +(defun stop-ide-drag (obj data) + (on-ide-drag-move obj data) + (on-ide-drag-leave obj)) (defgeneric create-window (clog-obj title &key html-id content left top width height) @@ -90,24 +81,25 @@ "
- ~A - X + style='flex-container;display:flex;align-items:stretch;'> + ~A + X ~A
~A
+
+
" top left width height html-id html-id html-id title html-id top-bar html-id content html-id) :html-id html-id)) - (title-bar (attach-as-child win (format nil "~A-title-bar" html-id))) - (close-x (attach-as-child win (format nil "~A-close" html-id)))) - (set-on-touch-start title-bar 'on-mouse-down) - (set-on-mouse-down title-bar 'on-mouse-down) - (set-on-click close-x (lambda (obj) - (setf (hiddenp win) t))) + (title (attach-as-child win (format nil "~A-title" html-id))) + (close-x (attach-as-child win (format nil "~A-close" html-id)))) + (set-on-pointer-down title 'on-ide-drag-down :capture-pointer t) + (set-on-click close-x (lambda (obj) + (setf (hiddenp win) t))) win)) (defun do-ide-file-new (obj)