mirror of
https://github.com/rabbibotton/clog.git
synced 2025-12-06 02:30:42 -08:00
Better window movement
This commit is contained in:
David Botton
parent
4eba57ec56
commit
9f2fe6b4b4
3 changed files with 180 additions and 41 deletions
144
clog-base.lisp
144
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 ;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 @@
|
|||
"<div style='position:fixed;top:~Apx;left:~Apx;width:~Apx;height:~Apx;'
|
||||
class='w3-card-4 w3-white w3-border'>
|
||||
<div id='~A-title-bar' class='w3-container w3-black'
|
||||
style='user-select: none;cursor: move;'
|
||||
data-drag-obj='~A'>
|
||||
<span id='~A-title'>~A</span>
|
||||
<span id='~A-close' class='w3-right'
|
||||
style='cursor: pointer;user-select: none;'>X</span>
|
||||
style='flex-container;display:flex;align-items:stretch;'>
|
||||
<span data-drag-obj='~A' id='~A-title'
|
||||
style='flex-grow:9;user-select:none;cursor:move;'>~A</span>
|
||||
<span id='~A-close'
|
||||
style='cursor:pointer;user-select:none;'>X</span>
|
||||
~A
|
||||
</div>
|
||||
<div id='~A-body' style='right:0;height:100%;margin: 0 auto;'>~A</div>
|
||||
<div id='~A-size' style='user-select:none;cursor:se-resize;opacity:0'
|
||||
class='w3-right'>+</div>
|
||||
</div>"
|
||||
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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue