mirror of
https://github.com/rabbibotton/clog.git
synced 2025-12-06 02:30:42 -08:00
223 lines
14 KiB
Common Lisp
223 lines
14 KiB
Common Lisp
(in-package :clog-tools)
|
|
|
|
;; Control-List utilities
|
|
|
|
(defun init-control-list (app panel-id)
|
|
"Initialize new control list for PANEL-ID on instance of APP."
|
|
(setf (gethash panel-id (control-lists app)) (make-hash-table :test #'equalp)))
|
|
|
|
(defun destroy-control-list (app panel-id)
|
|
"Destroy the control-list on PANEL-ID"
|
|
(remhash panel-id (control-lists app)))
|
|
|
|
(defun get-control-list (app panel-id)
|
|
"Rerieve the control-list hash table on PANEL-ID"
|
|
(let ((h (gethash panel-id (control-lists app))))
|
|
(if h
|
|
h
|
|
(make-hash-table* :test #'equalp)))) ;; return empty hash to avoid map fails
|
|
|
|
(defun add-to-control-list (app panel-id control)
|
|
"Add a CONTROL on to control-list on PANEL-ID"
|
|
(let ((html-id (format nil "~A" (html-id control))))
|
|
(setf (gethash html-id (get-control-list app panel-id)) control)))
|
|
|
|
(defun get-from-control-list (app panel-id html-id)
|
|
"Get control identified my HTML-ID from control-list on PANEL-ID"
|
|
(gethash html-id (get-control-list app panel-id)))
|
|
|
|
(defun remove-from-control-list (app panel-id html-id)
|
|
"Remove a control identified by HTML-ID from control-list on PANEL-ID"
|
|
(remhash html-id (get-control-list app panel-id)))
|
|
|
|
(defun remove-deleted-from-control-list (app panel-id)
|
|
"Remove any deleted control from control-list"
|
|
(maphash (lambda (html-id control)
|
|
(when (equalp (js-query control (format nil "$.contains(document.documentElement, ~A)"
|
|
(clog::script-id control))) "false")
|
|
(remove-from-control-list app panel-id html-id)))
|
|
(get-control-list app panel-id)))
|
|
|
|
;; Contorl List Window
|
|
|
|
(defun on-show-control-list-win (obj)
|
|
"Show control list for selecting and manipulating controls by name"
|
|
(let* ((app (connection-data-item obj "builder-app-data"))
|
|
(is-hidden nil)
|
|
(auto-mode nil)
|
|
(content (create-panel (connection-body obj) :positioning :fixed
|
|
:width 220
|
|
:top 40
|
|
:left 0 :bottom 0
|
|
:class "w3-border-right"))
|
|
(side-panel (create-panel content :top 0 :right 0 :bottom 0 :width 10))
|
|
(pin (create-div side-panel :content "☑" :class "w3-small"))
|
|
(sheight (floor (/ (height content) 2)))
|
|
(swidth (floor (width content)))
|
|
(divider (create-panel content :top sheight :height 10 :left 0 :right 10))
|
|
(control-list (create-panel content :height (- sheight 10) :left 0 :bottom 0 :right 10))
|
|
(pallete (create-select content))
|
|
(adj-size 0))
|
|
(set-geometry pallete :left 0 :top 0 :height sheight :width (- swidth 10))
|
|
(setf (left-panel app) content)
|
|
(setf (hiddenp (left-panel app)) t)
|
|
(setf (background-color divider) :black)
|
|
(setf (tab-index divider) "-1")
|
|
(setf (cursor divider) :ns-resize)
|
|
(setf (background-color content) :gray)
|
|
(setf (background-color pallete) :gray)
|
|
(setf (color pallete) :white)
|
|
(setf (positioning pallete) :absolute)
|
|
(setf (size pallete) 2)
|
|
(setf (advisory-title pallete) (format nil "<ctrl/cmd> place static~%<shift> child to current selection"))
|
|
(setf (select-tool app) pallete)
|
|
(setf (overflow control-list) :auto)
|
|
(reset-control-pallete obj)
|
|
(setf (control-list-win app) control-list)
|
|
(setf (advisory-title content)
|
|
(format nil "Drag and drop order~%Double click non-focusable~%~
|
|
<ctrl/cmd> place as static~%<shift> child to current selection"))
|
|
(setf (background-color side-panel) :black)
|
|
(flet ((on-size (obj)
|
|
(declare (ignore obj))
|
|
(setf sheight (floor (/ (height content) 2)))
|
|
(when (and (> (- sheight adj-size) 5)
|
|
(> (+ (- sheight 10) adj-size) 5))
|
|
(set-geometry pallete :height (- sheight adj-size))
|
|
(set-geometry divider :top (- sheight adj-size))
|
|
(set-geometry control-list :height (+ (- sheight 10) adj-size)))))
|
|
(set-on-resize (window (connection-body obj)) #'on-size)
|
|
(set-on-full-screen-change (html-document (connection-body obj)) #'on-size)
|
|
(set-on-orientation-change (window (connection-body obj)) #'on-size)
|
|
(set-on-pointer-down divider (lambda (obj data)
|
|
(setf (getf data :client-y) (+ adj-size
|
|
(getf data :client-y)))
|
|
(set-on-pointer-up (connection-body obj)
|
|
(lambda (obj data)
|
|
(declare (ignore data))
|
|
(set-on-pointer-up (connection-body obj) nil)
|
|
(set-on-pointer-move (connection-body obj) nil)))
|
|
(set-on-pointer-move (connection-body obj)
|
|
(lambda (obj new-data)
|
|
(setf adj-size (- (getf data :client-y)
|
|
(getf new-data :client-y)))
|
|
(on-size obj))))
|
|
:capture-pointer t))
|
|
(set-on-click side-panel (lambda (obj)
|
|
(declare (ignore obj))
|
|
(cond (auto-mode
|
|
(setf auto-mode nil)
|
|
(setf (text-value pin) "☑")
|
|
(setf (width content) "220px")
|
|
(setf (hiddenp pallete) nil)
|
|
(setf is-hidden nil))
|
|
(t
|
|
(setf auto-mode t)
|
|
(setf (text-value pin) "☐")
|
|
(setf (width content) "10px")
|
|
(setf (hiddenp pallete) t)
|
|
(setf is-hidden t)))))
|
|
(set-on-mouse-leave side-panel (lambda (obj)
|
|
(declare (ignore obj))
|
|
(when auto-mode
|
|
(cond (is-hidden
|
|
(setf (width content) "220px")
|
|
(setf (hiddenp pallete) nil)
|
|
(setf is-hidden nil))
|
|
(t
|
|
(setf (width content) "10px")
|
|
(setf (hiddenp pallete) t)
|
|
(setf is-hidden t))))))))
|
|
|
|
(defun on-populate-control-list-win (content &key win)
|
|
"Populate the control-list-window to allow drag and drop adjust of order
|
|
of controls and double click to select control."
|
|
(with-sync-event (content)
|
|
(let ((app (connection-data-item content "builder-app-data")))
|
|
(let ((panel-id (html-id content))
|
|
(last-ctl nil))
|
|
(when (control-list-win app)
|
|
(let ((lwin (control-list-win app)))
|
|
(setf (inner-html lwin) "")
|
|
(set-on-mouse-click (create-div lwin :content (attribute content "data-clog-name"))
|
|
(lambda (obj data)
|
|
(declare (ignore obj data))
|
|
(deselect-current-control app)
|
|
(on-populate-control-properties-win content :win win)
|
|
(on-populate-control-list-win content :win win)))
|
|
(labels ((add-siblings (control sim)
|
|
(let (dln dcc)
|
|
(loop
|
|
(when (equal (html-id control) "undefined") (return))
|
|
(setf dcc (attribute control "data-clog-composite-control"))
|
|
(setf dln (attribute control "data-clog-name"))
|
|
(unless (equal dln "undefined")
|
|
(let ((list-item (create-div lwin :content (format nil "↕ ~A~A" sim dln)))
|
|
(status (hiddenp (get-placer control))))
|
|
(if status
|
|
(setf (color list-item) :darkred)
|
|
(setf (background-color list-item) :grey))
|
|
(setf (draggablep list-item) t)
|
|
(setf (attribute list-item "data-clog-control") (html-id control))
|
|
;; click to select item
|
|
(set-on-mouse-down list-item
|
|
(lambda (obj data)
|
|
(let* ((html-id (attribute obj "data-clog-control"))
|
|
(control (get-from-control-list app
|
|
panel-id
|
|
html-id)))
|
|
(cond ((or (getf data :shift-key)
|
|
(getf data :ctrl-key)
|
|
(getf data :meta-key))
|
|
(when (drop-new-control app content data)
|
|
(incf-next-id content)))
|
|
(t
|
|
(when last-ctl
|
|
(set-border last-ctl "0px" :dotted :blue))
|
|
(set-border list-item "2px" :dotted :blue)
|
|
(setf last-ctl list-item)
|
|
(select-control control))))))
|
|
(set-on-double-click list-item
|
|
(lambda (obj)
|
|
(let* ((html-id (attribute obj "data-clog-control"))
|
|
(control (get-from-control-list app
|
|
panel-id
|
|
html-id))
|
|
(placer (get-placer control))
|
|
(state (hiddenp placer)))
|
|
(setf (hiddenp placer) (not state))
|
|
(select-control control)
|
|
(on-populate-control-list-win content :win win))))
|
|
;; drag and drop to change
|
|
(set-on-drag-over list-item (lambda (obj)(declare (ignore obj))()))
|
|
(set-on-drop list-item
|
|
(lambda (obj data)
|
|
(let* ((id (attribute obj "data-clog-control"))
|
|
(control1 (get-from-control-list app
|
|
panel-id
|
|
id))
|
|
(control2 (get-from-control-list app
|
|
panel-id
|
|
(getf data :drag-data)))
|
|
(placer1 (get-placer control1))
|
|
(placer2 (get-placer control2)))
|
|
(if (getf data :shift-key)
|
|
(place-inside-bottom-of control1 control2)
|
|
(place-before control1 control2))
|
|
(place-after control2 placer2)
|
|
(set-geometry placer1 :top (position-top control1)
|
|
:left (position-left control1)
|
|
:width (client-width control1)
|
|
:height (client-height control1))
|
|
(set-geometry placer2 :top (position-top control2)
|
|
:left (position-left control2)
|
|
:width (client-width control2)
|
|
:height (client-height control2))
|
|
(on-populate-control-properties-win content :win win)
|
|
(on-populate-control-list-win content :win win))))
|
|
(set-on-drag-start list-item (lambda (obj)(declare (ignore obj))())
|
|
:drag-data (html-id control))
|
|
(when (equal dcc "undefined") ; when t is not a composite control
|
|
(add-siblings (first-child control) (format nil "~A→" sim)))))
|
|
(setf control (next-sibling control))))))
|
|
(add-siblings (first-child content) ""))))))))
|