mirrors/clog
1
Fork 0
mirror of https://github.com/rabbibotton/clog.git synced 2025-12-06 02:30:42 -08:00
Code Issues Projects Releases Wiki Activity

Better window movement

Browse source
This commit is contained in:
David Botton 2021-02-07 16:47:03 -05:00
parent 4eba57ec56
commit 9f2fe6b4b4
3 changed files with 180 additions and 41 deletions
Download patch file Download diff file Expand all files Collapse all files

70
demos/03-demo.lisp
View file

@ -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)