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

performace enhacements

Browse source
This commit is contained in:
David Botton 2024-06-21 18:18:14 -04:00
parent 519cadddd4
commit 452ee0b1b8
5 changed files with 437 additions and 422 deletions
Download patch file Download diff file Expand all files Collapse all files

27
source/clog-element.lisp
View file

@ -2384,34 +2384,43 @@ used for DOM tree walking or other throw away purposes."))
;; first-child ;; ;; first-child ;;
;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;
(defgeneric first-child (clog-element) (defgeneric first-child (clog-element &key no-attach)
(:documentation "Traverse to first child element. If Child does not have an (:documentation "Traverse to first child element. If Child does not have an
html id than Element_Type will have an ID of undefined and therefore attached html id than Element_Type will have an ID of undefined and therefore attached
to no actual HTML element.")) to no actual HTML element."))
(defmethod first-child ((obj clog-element)) (defmethod first-child ((obj clog-element) &key no-attach)
(attach-as-child obj (jquery-query obj "children().first().prop('id')"))) (let ((id (jquery-query obj "children().first().prop('id')")))
(if (or no-attach (equalp id "undefined"))
(make-clog-element (connection-id obj) id :clog-type 'clog-element))
(attach-as-child obj id)))
;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;
;; next-sibling ;; ;; next-sibling ;;
;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;
(defgeneric next-sibling (clog-element) (defgeneric next-sibling (clog-element &key no-attach)
(:documentation "Traverse to next sibling element. If Child does not have an (:documentation "Traverse to next sibling element. If Child does not have an
html id than Element_Type will have an ID of undefined and therefore attached html id than Element_Type will have an ID of undefined and therefore attached
to no actual HTML element.")) to no actual HTML element."))
(defmethod next-sibling ((obj clog-element)) (defmethod next-sibling ((obj clog-element) &key no-attach)
(attach-as-child obj (jquery-query obj "next().prop('id')"))) (let ((id (jquery-query obj "next().prop('id')")))
(if (or no-attach (equalp id "undefined"))
(make-clog-element (connection-id obj) id :clog-type 'clog-element))
(attach-as-child obj id)))
;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;
;; previous-sibling ;; ;; previous-sibling ;;
;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;
(defgeneric previous-sibling (clog-element) (defgeneric previous-sibling (clog-element &key no-attach)
(:documentation "Traverse to previous sibling element. (:documentation "Traverse to previous sibling element.
If Child does not have an html id than Element_Type will have an ID of If Child does not have an html id than Element_Type will have an ID of
undefined and therefore attached to no actual HTML elemen.")) undefined and therefore attached to no actual HTML elemen."))
(defmethod previous-sibling ((obj clog-element)) (defmethod previous-sibling ((obj clog-element) &key no-attach)
(attach-as-child obj (jquery-query obj "previous().prop('id')"))) (let ((id (jquery-query obj "previous().prop('id')")))
(if (or no-attach (equalp id "undefined"))
(make-clog-element (connection-id obj) id :clog-type 'clog-element))
(attach-as-child obj id)))

65
source/clog-gui.lisp
View file

@ -990,38 +990,39 @@ The on-window-change clog-obj received is the new window"))
"Handle mouse down on drag items" "Handle mouse down on drag items"
(let ((app (connection-data-item obj "clog-gui"))) (let ((app (connection-data-item obj "clog-gui")))
(setf (in-drag app) (attribute obj "data-drag-type")) (setf (in-drag app) (attribute obj "data-drag-type"))
(let* ((target (gethash (attribute obj "data-drag-obj") (windows app))) (handler-case
(pointer-x (getf data ':screen-x)) (let* ((target (gethash (attribute obj "data-drag-obj") (windows app)))
(pointer-y (getf data ':screen-y)) (pointer-x (getf data ':screen-x))
(obj-top) (pointer-y (getf data ':screen-y))
(obj-left) (obj-top)
(perform-drag nil)) (obj-left)
(when target (perform-drag nil))
(setf (drag-obj app) target) (when target
(cond ((equalp (in-drag app) "m") (setf (drag-obj app) target)
(setf obj-top (cond ((equalp (in-drag app) "m")
(js-to-integer (top (drag-obj app)))) (setf obj-top
(setf obj-left (js-to-integer (top (drag-obj app))))
(js-to-integer (left (drag-obj app)))) (setf obj-left
(setf perform-drag (fire-on-window-can-move (drag-obj app)))) (js-to-integer (left (drag-obj app))))
((equalp (in-drag app) "s") (setf perform-drag (fire-on-window-can-move (drag-obj app))))
(setf obj-top (height (drag-obj app))) ((equalp (in-drag app) "s")
(setf obj-left (width (drag-obj app))) (setf obj-top (height (drag-obj app)))
(setf perform-drag (fire-on-window-can-size (drag-obj app)))) (setf obj-left (width (drag-obj app)))
(t (setf perform-drag (fire-on-window-can-size (drag-obj app))))
(format t "Warning - invalid data-drag-type attribute"))) (t
(unless (keep-on-top (drag-obj app)) (format t "Warning - invalid data-drag-type attribute")))
(setf (z-index (drag-obj app)) (incf (last-z app)))) (unless (keep-on-top (drag-obj app))
(fire-on-window-change (drag-obj app) app) (setf (z-index (drag-obj app)) (incf (last-z app))))
(setf (drag-y app) (- pointer-y obj-top)) (fire-on-window-change (drag-obj app) app)
(setf (drag-x app) (- pointer-x obj-left))) (setf (drag-y app) (- pointer-y obj-top))
(cond (perform-drag (setf (drag-x app) (- pointer-x obj-left)))
(set-on-pointer-move obj 'on-gui-drag-move) (cond (perform-drag
(set-on-pointer-cancel obj 'on-gui-drag-stop) (set-on-pointer-move obj 'on-gui-drag-move)
(set-on-pointer-up obj 'on-gui-drag-stop)) (set-on-pointer-cancel obj 'on-gui-drag-stop)
(t (set-on-pointer-up obj 'on-gui-drag-stop))
(setf (in-drag app) nil)))))) (t
(setf (in-drag app) nil))))
(error () nil))))
;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;
;; on-gui-drag-move ;; ;; on-gui-drag-move ;;
;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;

19
tools/clog-builder-control-list.lisp
View file

@ -14,8 +14,8 @@
"Rerieve the control-list hash table on PANEL-ID" "Rerieve the control-list hash table on PANEL-ID"
(let ((h (gethash panel-id (control-lists app)))) (let ((h (gethash panel-id (control-lists app))))
(if h (if h
h h
(make-hash-table* :test #'equalp)))) ;; return empty hash to avoid map fails (make-hash-table* :test #'equalp)))) ;; return empty hash to avoid map fails
(defun add-to-control-list (app panel-id control) (defun add-to-control-list (app panel-id control)
"Add a CONTROL on to control-list on PANEL-ID" "Add a CONTROL on to control-list on PANEL-ID"
@ -119,13 +119,15 @@ of controls and double click to select control."
(let ((app (connection-data-item content "builder-app-data"))) (let ((app (connection-data-item content "builder-app-data")))
(if clear (if clear
(when (control-list-win app) (when (control-list-win app)
(setf (inner-html (control-list-win app)) "")) (setf (inner-html (control-list-win app)) "")
(browser-gc content))
(with-sync-event (content) (with-sync-event (content)
(let ((panel-id (html-id content)) (let ((panel-id (html-id content))
(last-ctl nil)) (last-ctl nil))
(when (control-list-win app) (when (control-list-win app)
(let ((lwin (control-list-win app))) (let ((lwin (control-list-win app)))
(setf (inner-html lwin) "") (setf (inner-html lwin) "")
(browser-gc content)
(set-on-mouse-click (create-div lwin :content (attribute content "data-clog-name")) (set-on-mouse-click (create-div lwin :content (attribute content "data-clog-name"))
(lambda (obj data) (lambda (obj data)
(declare (ignore obj data)) (declare (ignore obj data))
@ -135,11 +137,12 @@ of controls and double click to select control."
(labels ((add-siblings (control sim) (labels ((add-siblings (control sim)
(let (dln dcc) (let (dln dcc)
(loop (loop
(when (equal (html-id control) "undefined") (return)) (when (equalp (html-id control) "undefined")
(setf dcc (attribute control "data-clog-composite-control")) (return))
(setf dln (attribute control "data-clog-name")) (setf dln (attribute control "data-clog-name"))
(unless (or (equal dln "undefined") (unless (or (equal dln "undefined")
(eq dln nil)) (eq dln nil))
(setf dcc (attribute control "data-clog-composite-control"))
(let ((list-item (create-div lwin :content (format nil "↕ ~A~A" sim dln))) (let ((list-item (create-div lwin :content (format nil "↕ ~A~A" sim dln)))
(status (hiddenp (get-placer control)))) (status (hiddenp (get-placer control))))
(if status (if status
@ -206,6 +209,6 @@ of controls and double click to select control."
(set-on-drag-start list-item (lambda (obj)(declare (ignore obj))()) (set-on-drag-start list-item (lambda (obj)(declare (ignore obj))())
:drag-data (html-id control)) :drag-data (html-id control))
(when (equal dcc "undefined") ; when t is not a composite control (when (equal dcc "undefined") ; when t is not a composite control
(add-siblings (first-child control) (format nil "~A→" sim))))) (add-siblings (first-child control :no-attach t) (format nil "~A→" sim)))))
(setf control (next-sibling control)))))) (setf control (next-sibling control :no-attach t))))))
(add-siblings (first-child content) "")))))))))) (add-siblings (first-child content :no-attach t) ""))))))))))

4
tools/clog-builder-control-properties.lisp
View file

@ -32,7 +32,9 @@
(when obj (when obj
(let ((app (connection-data-item obj "builder-app-data"))) (let ((app (connection-data-item obj "builder-app-data")))
(if clear (if clear
(setf (inner-html (properties-list app)) "") (progn
(setf (inner-html (properties-list app)) "")
(browser-gc obj))
(with-sync-event (obj) (with-sync-event (obj)
(bordeaux-threads:make-thread (lambda () (on-populate-control-events-win obj))) (bordeaux-threads:make-thread (lambda () (on-populate-control-events-win obj)))
(let* ((prop-win (control-properties-win app)) (let* ((prop-win (control-properties-win app))

744
tools/clog-builder-panels.lisp
View file

@ -22,11 +22,11 @@
(let (snap (let (snap
(app (connection-data-item content "builder-app-data"))) (app (connection-data-item content "builder-app-data")))
(maphash (maphash
(lambda (html-id control) (lambda (html-id control)
(declare (ignore html-id)) (declare (ignore html-id))
(place-inside-bottom-of hide-loc (place-inside-bottom-of hide-loc
(get-placer control))) (get-placer control)))
(get-control-list app panel-id)) (get-control-list app panel-id))
(let ((data (let ((data
(create-child content "<data />" (create-child content "<data />"
:html-id (format nil "I~A" (get-universal-time))))) :html-id (format nil "I~A" (get-universal-time)))))
@ -50,10 +50,10 @@
(jquery content)))) (jquery content))))
(destroy data)) (destroy data))
(maphash (maphash
(lambda (html-id control) (lambda (html-id control)
(declare (ignore html-id)) (declare (ignore html-id))
(place-after control (get-placer control))) (place-after control (get-placer control)))
(get-control-list app panel-id)) (get-control-list app panel-id))
snap))) snap)))
(defun save-panel (fname content panel-id hide-loc) (defun save-panel (fname content panel-id hide-loc)
@ -67,53 +67,53 @@
(let* ((create-type (getf control-record :create-type)) (let* ((create-type (getf control-record :create-type))
(control-type-name (getf control-record :name)) (control-type-name (getf control-record :name))
(control (cond ((eq create-type :base) (control (cond ((eq create-type :base)
(funcall (getf control-record :create) parent (funcall (getf control-record :create) parent
:html-id uid)) :html-id uid))
((eq create-type :custom) ((eq create-type :custom)
(funcall (getf control-record :create) parent (funcall (getf control-record :create) parent
(getf control-record :create-content) (getf control-record :create-content)
:html-id uid)) :html-id uid))
((eq create-type :custom-block) ((eq create-type :custom-block)
(let ((c (funcall (getf control-record :create) parent (let ((c (funcall (getf control-record :create) parent
:content custom-query :content custom-query
:html-id uid))) :html-id uid)))
(setf (attribute c "data-original-html") custom-query) (setf (attribute c "data-original-html") custom-query)
c)) c))
((eq create-type :custom-query) ((eq create-type :custom-query)
(funcall (getf control-record :create) parent (funcall (getf control-record :create) parent
custom-query custom-query
:html-id uid)) :html-id uid))
((eq create-type :paste) ((eq create-type :paste)
(let ((c (create-child parent custom-query (let ((c (create-child parent custom-query
:html-id uid))) :html-id uid)))
(setf control-type-name (attribute c "data-clog-type")) (setf control-type-name (attribute c "data-clog-type"))
(when (equalp control-type-name "undefined") (when (equalp control-type-name "undefined")
(setf (attribute c "data-clog-type") "div") (setf (attribute c "data-clog-type") "div")
(setf control-type-name "div")) (setf control-type-name "div"))
(let ((cr (control-info control-type-name))) (let ((cr (control-info control-type-name)))
(change-class c (getf cr :clog-type))) (change-class c (getf cr :clog-type)))
c)) c))
((eq create-type :element) ((eq create-type :element)
(funcall (getf control-record :create) parent (funcall (getf control-record :create) parent
:html-id uid :html-id uid
:content (if (equal (getf control-record :create-content) "") :content (if (equal (getf control-record :create-content) "")
"" ""
(format nil "~A-~A" (format nil "~A-~A"
(getf control-record :create-content) (getf control-record :create-content)
(next-id content))))) (next-id content)))))
((eq create-type :form) ((eq create-type :form)
(funcall (getf control-record :create) parent (funcall (getf control-record :create) parent
(getf control-record :create-param) (getf control-record :create-param)
:html-id uid :html-id uid
:value (if (equal (getf control-record :create-value) "") :value (if (equal (getf control-record :create-value) "")
"" ""
(format nil "~A-~A" (format nil "~A-~A"
(getf control-record :create-value) (getf control-record :create-value)
(next-id content))))) (next-id content)))))
((eq create-type :textarea) ((eq create-type :textarea)
(funcall (getf control-record :create) parent (funcall (getf control-record :create) parent
:html-id uid :html-id uid
:value (getf control-record :create-value))) :value (getf control-record :create-value)))
(t nil)))) (t nil))))
(when control (when control
(setf (attribute control "data-clog-type") control-type-name) (setf (attribute control "data-clog-type") control-type-name)
@ -130,35 +130,35 @@
(let* ((control-record (control-info (value (select-tool app)))) (let* ((control-record (control-info (value (select-tool app))))
(control-type-name (getf control-record :create-type))) (control-type-name (getf control-record :create-type)))
(cond ((eq control-type-name :custom-query) (cond ((eq control-type-name :custom-query)
(input-dialog win "Enter html (must have an outer element):" (input-dialog win "Enter html (must have an outer element):"
(lambda (custom-query) (lambda (custom-query)
(when custom-query (when custom-query
(do-drop-new-control (do-drop-new-control
app content data app content data
:win win :win win
:custom-query custom-query))) :custom-query custom-query)))
:width 500 :width 500
:height 300 :height 300
:rows 5 :rows 5
:size 40 :size 40
:title "Custom HTML Control" :title "Custom HTML Control"
:default-value (getf control-record :create-content))) :default-value (getf control-record :create-content)))
((eq control-type-name :custom-block) ((eq control-type-name :custom-block)
(input-dialog win "Enter html to create control:" (input-dialog win "Enter html to create control:"
(lambda (custom-query) (lambda (custom-query)
(when custom-query (when custom-query
(do-drop-new-control (do-drop-new-control
app content data app content data
:win win :win win
:custom-query custom-query))) :custom-query custom-query)))
:width 500 :width 500
:height 300 :height 300
:rows 5 :rows 5
:size 40 :size 40
:title "Custom HTML Block" :title "Custom HTML Block"
:default-value (getf control-record :create-content))) :default-value (getf control-record :create-content)))
(t (t
(do-drop-new-control app content data :win win)))))) (do-drop-new-control app content data :win win))))))
(defun do-drop-new-control (app content data &key win custom-query) (defun do-drop-new-control (app content data &key win custom-query)
"Create new control dropped at event DATA on CONTENT of WIN)" "Create new control dropped at event DATA on CONTENT of WIN)"
@ -167,11 +167,11 @@
(control-type-name (getf control-record :name)) (control-type-name (getf control-record :name))
(positioning (cond ((or (getf data :ctrl-key) (positioning (cond ((or (getf data :ctrl-key)
(getf data :meta-key)) (getf data :meta-key))
:static) :static)
((getf control-record :positioning) ((getf control-record :positioning)
(getf control-record :positioning)) (getf control-record :positioning))
(t (t
:absolute))) :absolute)))
(parent (when (getf data :shift-key) (parent (when (getf data :shift-key)
(current-control app))) (current-control app)))
(control (create-control (if parent (control (create-control (if parent
@ -184,29 +184,29 @@
(next-id content)) (next-id content))
:custom-query custom-query))) :custom-query custom-query)))
(cond (control (cond (control
;; panel directly clicked with a control type selected ;; panel directly clicked with a control type selected
;; setup control ;; setup control
(setf (attribute control "data-clog-name") (setf (attribute control "data-clog-name")
(format nil "~A-~A" control-type-name (next-id content))) (format nil "~A-~A" control-type-name (next-id content)))
(setf (value (select-tool app)) "") (setf (value (select-tool app)) "")
(setf (box-sizing control) :content-box) (setf (box-sizing control) :content-box)
(setf (positioning control) positioning) (setf (positioning control) positioning)
(set-geometry control (set-geometry control
:left (getf data :x) :left (getf data :x)
:top (getf data :y)) :top (getf data :y))
(when (equalp (attribute control "data-clog-composite-control") "undefined") (when (equalp (attribute control "data-clog-composite-control") "undefined")
(add-sub-controls control content :win win)) (add-sub-controls control content :win win))
(setup-control content control :win win) (setup-control content control :win win)
(select-control control) (select-control control)
(on-populate-control-list-win content :win win) (on-populate-control-list-win content :win win)
(jquery-execute (get-placer content) "trigger('clog-builder-snap-shot')") (jquery-execute (get-placer content) "trigger('clog-builder-snap-shot')")
t) t)
(t (t
;; panel directly clicked with select tool or no control type to add ;; panel directly clicked with select tool or no control type to add
(deselect-current-control app) (deselect-current-control app)
(on-populate-control-properties-win content :win win) (on-populate-control-properties-win content :win win)
(on-populate-control-list-win content :win win) (on-populate-control-list-win content :win win)
nil)))) nil))))
(defun setup-control (content control &key win) (defun setup-control (content control &key win)
"Setup CONTROL by creating pacer and setting up events for manipulation" "Setup CONTROL by creating pacer and setting up events for manipulation"
@ -214,19 +214,18 @@
(panel-id (html-id content)) (panel-id (html-id content))
(touch-x 0) (touch-x 0)
(touch-y 0) (touch-y 0)
(placer (create-div control :auto-place nil (placer (create-div control
:class "placer" :class "placer"
:html-id (format nil "p-~A" (html-id control))))) :style "position:absolute;box-sizing:content-box;tabindex:0"
:html-id (format nil "p-~A" (html-id control)))))
(add-to-control-list app panel-id control) (add-to-control-list app panel-id control)
(setf (attribute placer "data-panel-id") panel-id) (setf (attribute placer "data-panel-id") panel-id)
;; setup placer ;; setup placer
(set-geometry placer :top (position-top control) (set-geometry placer :top (position-top control)
:left (position-left control) :left (position-left control)
:width (client-width control) :width (client-width control)
:height (client-height control)) :height (client-height control))
(place-after control placer) (place-after control placer)
(setf (box-sizing placer) :content-box)
(setf (positioning placer) :absolute)
(jquery-execute placer (format nil "draggable({snap:'.placer',snapMode:'inner',cursor:'crosshair'})~ (jquery-execute placer (format nil "draggable({snap:'.placer',snapMode:'inner',cursor:'crosshair'})~
.resizable({alsoResize:'#~A',autoHide:true})" .resizable({alsoResize:'#~A',autoHide:true})"
(html-id control))) (html-id control)))
@ -241,121 +240,121 @@
(meta (getf data :meta-key)) (meta (getf data :meta-key))
(shift (getf data :shift-key))) (shift (getf data :shift-key)))
(cond ((equal key "ArrowUp") (cond ((equal key "ArrowUp")
(if shift (if shift
(set-geometry control :height (1- (height control))) (set-geometry control :height (1- (height control)))
(set-geometry control :top (1- (position-top control))))) (set-geometry control :top (1- (position-top control)))))
((equal key "ArrowDown") ((equal key "ArrowDown")
(if shift (if shift
(set-geometry control :height (+ (height control) 2)) (set-geometry control :height (+ (height control) 2))
(set-geometry control :top (+ (position-top control) 2)))) (set-geometry control :top (+ (position-top control) 2))))
((equal key "ArrowRight") ((equal key "ArrowRight")
(if shift (if shift
(set-geometry control :width (+ (width control) 2)) (set-geometry control :width (+ (width control) 2))
(set-geometry control :left (+ (position-left control) 2)))) (set-geometry control :left (+ (position-left control) 2))))
((equal key "ArrowLeft") ((equal key "ArrowLeft")
(if shift (if shift
(set-geometry control :width (1- (width control))) (set-geometry control :width (1- (width control)))
(set-geometry control :left (1- (position-left control))))) (set-geometry control :left (1- (position-left control)))))
((and (equal key "c") ((and (equal key "c")
(or meta ctrl)) (or meta ctrl))
(blur placer)) (blur placer))
((and (equal key "v") ((and (equal key "v")
(or meta ctrl)) (or meta ctrl))
(blur placer)) (blur placer))
((and (equal key "x") ((and (equal key "x")
(or meta ctrl)) (or meta ctrl))
(blur placer))) (blur placer)))
(set-geometry placer :top (position-top control) (set-geometry placer :top (position-top control)
:left (position-left control) :left (position-left control)
:width (client-width control) :width (client-width control)
:height (client-height control)) :height (client-height control))
(jquery-execute placer "trigger('clog-builder-snap-shot')") (jquery-execute placer "trigger('clog-builder-snap-shot')")
(set-properties-after-geomentry-change control)))) (set-properties-after-geomentry-change control))))
(set-on-touch-start placer (lambda (obj data) (set-on-touch-start placer (lambda (obj data)
(declare (ignore obj)) (declare (ignore obj))
(setf touch-x (getf data :X)) (setf touch-x (getf data :X))
(setf touch-y (getf data :Y)))) (setf touch-y (getf data :Y))))
(set-on-touch-move placer (lambda (obj data) (set-on-touch-move placer (lambda (obj data)
(declare (ignore obj)) (declare (ignore obj))
(set-geometry control :top (+ (position-top control) (set-geometry control :top (+ (position-top control)
(- (getf data :y) touch-y)) (- (getf data :y) touch-y))
:left (+ (position-left control) :left (+ (position-left control)
(- (getf data :x) touch-x))) (- (getf data :x) touch-x)))
(setf touch-x (getf data :X)) (setf touch-x (getf data :X))
(setf touch-y (getf data :Y)))) (setf touch-y (getf data :Y))))
(set-on-touch-end placer (lambda (obj data) (set-on-touch-end placer (lambda (obj data)
(declare (ignore obj data)) (declare (ignore obj data))
(set-geometry placer :units "" (set-geometry placer :units ""
:top (top control) :top (top control)
:left (left control)) :left (left control))
(select-control control) (select-control control)
(jquery-execute placer "trigger('clog-builder-snap-shot')") (jquery-execute placer "trigger('clog-builder-snap-shot')")
(set-properties-after-geomentry-change control))) (set-properties-after-geomentry-change control)))
(set-on-mouse-up placer (lambda (obj data) (set-on-mouse-up placer (lambda (obj data)
(declare (ignore obj data)) (declare (ignore obj data))
(set-geometry control :units "" (set-geometry control :units ""
:top (top placer) :top (top placer)
:left (left placer)) :left (left placer))
(set-geometry placer :units "" (set-geometry placer :units ""
:top (top control) :top (top control)
:left (left control)) :left (left control))
(select-control control) (select-control control)
(jquery-execute placer "trigger('clog-builder-snap-shot')") (jquery-execute placer "trigger('clog-builder-snap-shot')")
(set-properties-after-geomentry-change control))) (set-properties-after-geomentry-change control)))
(set-on-mouse-down placer (set-on-mouse-down placer
(lambda (obj data) (lambda (obj data)
(declare (ignore obj)) (declare (ignore obj))
(let ((last (current-control app)) (let ((last (current-control app))
(shift (getf data :shift-key))) (shift (getf data :shift-key)))
(if (and (select-tool app) (if (and (select-tool app)
(not (equal (value (select-tool app)) ""))) (not (equal (value (select-tool app)) "")))
(when (do-drop-new-control app content data :win win) (when (do-drop-new-control app content data :win win)
(incf-next-id content))) (incf-next-id content)))
(cond ((and last (cond ((and last
shift) shift)
(let* ((control1 last) (let* ((control1 last)
(control2 control) (control2 control)
(placer1 (get-placer control1)) (placer1 (get-placer control1))
(placer2 (get-placer control2))) (placer2 (get-placer control2)))
(place-inside-bottom-of control1 control2) (place-inside-bottom-of control1 control2)
(place-after control2 placer2) (place-after control2 placer2)
(place-after control2 placer2) (place-after control2 placer2)
(set-geometry placer1 :top (position-top control1) (set-geometry placer1 :top (position-top control1)
:left (position-left control1) :left (position-left control1)
:width (client-width control1) :width (client-width control1)
:height (client-height control1)) :height (client-height control1))
(set-geometry placer2 :top (position-top control2) (set-geometry placer2 :top (position-top control2)
:left (position-left control2) :left (position-left control2)
:width (client-width control2) :width (client-width control2)
:height (client-height control2))) :height (client-height control2)))
(select-control control) (select-control control)
(on-populate-control-properties-win content :win win) (on-populate-control-properties-win content :win win)
(on-populate-control-list-win content :win win)) (on-populate-control-list-win content :win win))
(t (t
(select-control control))) (select-control control)))
(when win (when win
(window-focus win)))) (window-focus win))))
:cancel-event t) :cancel-event t)
(set-on-mouse-double-click placer (set-on-mouse-double-click placer
(lambda (obj data) (lambda (obj data)
(declare (ignore obj data)) (declare (ignore obj data))
(setf (hiddenp placer) t) (setf (hiddenp placer) t)
(on-populate-control-list-win content :win win))) (on-populate-control-list-win content :win win)))
(set-on-event placer "resize" (set-on-event placer "resize"
(lambda (obj) (lambda (obj)
(set-properties-after-geomentry-change obj))) (set-properties-after-geomentry-change obj)))
(set-on-event placer "resizestop" (set-on-event placer "resizestop"
(lambda (obj) (lambda (obj)
(set-properties-after-geomentry-change obj) (set-properties-after-geomentry-change obj)
(jquery-execute placer "trigger('clog-builder-snap-shot')")) (jquery-execute placer "trigger('clog-builder-snap-shot')"))
:cancel-event t) :cancel-event t)
(set-on-event placer "drag" (set-on-event placer "drag"
(lambda (obj) (lambda (obj)
(declare (ignore obj)) (declare (ignore obj))
(set-geometry control :units "" (set-geometry control :units ""
:top (top placer) :top (top placer)
:left (left placer)) :left (left placer))
(set-properties-after-geomentry-change control))))) (set-properties-after-geomentry-change control)))))
(defun on-populate-loaded-window (content &key win) (defun on-populate-loaded-window (content &key win)
"Setup html imported in to CONTENT for use with Builder" "Setup html imported in to CONTENT for use with Builder"
@ -369,12 +368,12 @@
(defun set-properties-after-geomentry-change (control) (defun set-properties-after-geomentry-change (control)
"Set properties window geometry setting" "Set properties window geometry setting"
(set-property-display control "top" (top control)) (set-property-display control "top" (top control))
(set-property-display control "left" (left control)) (set-property-display control "left" (left control))
(set-property-display control "right" (right control)) (set-property-display control "right" (right control))
(set-property-display control "bottom" (bottom control)) (set-property-display control "bottom" (bottom control))
(set-property-display control "width" (client-width control)) (set-property-display control "width" (client-width control))
(set-property-display control "height" (client-height control))) (set-property-display control "height" (client-height control)))
;; Control selection utilities ;; Control selection utilities
@ -383,7 +382,9 @@
prevents access to use or activate the control directy and allows prevents access to use or activate the control directy and allows
manipulation of the control's location and size." manipulation of the control's location and size."
(when control (when control
(attach-as-child control (format nil "p-~A" (html-id control))))) (clog::make-clog-element (clog::connection-id control)
(format nil "p-~A" (html-id control))
:clog-type 'clog-element)))
(defun deselect-current-control (app) (defun deselect-current-control (app)
"Remove selection on current control and remove visual ques on its placer." "Remove selection on current control and remove visual ques on its placer."
@ -403,17 +404,17 @@ manipulation of the control's location and size."
"Select CONTROL as the current control and highlight its placer. "Select CONTROL as the current control and highlight its placer.
The actual original clog object used for creation must be used and The actual original clog object used for creation must be used and
not a temporarily attached one when using select-control." not a temporarily attached one when using select-control."
(let ((app (connection-data-item control "builder-app-data")) (let ((app (connection-data-item control "builder-app-data"))
(placer (get-placer control))) (placer (get-placer control)))
(unless (eq control (current-control app)) (unless (eq control (current-control app))
(deselect-current-control app) (deselect-current-control app)
(set-geometry placer :top (position-top control) (set-geometry placer :top (position-top control)
:left (position-left control) :left (position-left control)
:width (client-width control) :width (client-width control)
:height (client-height control)) :height (client-height control))
(setf (current-control app) control) (setf (current-control app) control)
(set-border placer (unit "px" 2) :solid :blue) (set-border placer (unit "px" 2) :solid :blue)
(on-populate-control-properties-win control)))) (on-populate-control-properties-win control))))
(defun add-sub-controls (parent content &key win paste) (defun add-sub-controls (parent content &key win paste)
"Setup html imported in to CONTENT starting with PARENT for use with Builder" "Setup html imported in to CONTENT starting with PARENT for use with Builder"
@ -436,7 +437,7 @@ not a temporarily attached one when using select-control."
(if paste (if paste
(prog1 (prog1
(format nil "e.attr('data-clog-name', e.attr('data-clog-name')+'-'+~A);" (format nil "e.attr('data-clog-name', e.attr('data-clog-name')+'-'+~A);"
(next-id content)) (next-id content))
(incf-next-id content)) (incf-next-id content))
"") "")
(mapcar (lambda (l) (mapcar (lambda (l)
@ -505,8 +506,8 @@ not a temporarily attached one when using select-control."
(*default-border-class* *builder-border-class*) (*default-border-class* *builder-border-class*)
ext-panel ext-panel
(win (create-gui-window obj :top 40 :left 225 (win (create-gui-window obj :top 40 :left 225
:width 645 :height 430 :width 645 :height 430
:client-movement *client-side-movement*)) :client-movement *client-side-movement*))
(box (create-panel-box-layout (window-content win) (box (create-panel-box-layout (window-content win)
:left-width 0 :right-width 0 :left-width 0 :right-width 0
:top-height 70 :bottom-height 0)) :top-height 70 :bottom-height 0))
@ -598,12 +599,12 @@ not a temporarily attached one when using select-control."
(when (or open-ext (when (or open-ext
*open-panels-as-popups*) *open-panels-as-popups*)
(multiple-value-bind (pop pop-win) (multiple-value-bind (pop pop-win)
(if (typep open-ext 'string) (if (typep open-ext 'string)
(progn (progn
(enable-clog-popup :path "/customboot" :boot-file open-ext) (enable-clog-popup :path "/customboot" :boot-file open-ext)
(open-clog-popup obj :path "/customboot" (open-clog-popup obj :path "/customboot"
:specs "width=640,height=480")) :specs "width=640,height=480"))
(open-clog-popup obj :specs "width=640,height=480")) (open-clog-popup obj :specs "width=640,height=480"))
(when pop (when pop
(let ((msg (create-button content :content "Panel is external. Click to bring to front."))) (let ((msg (create-button content :content "Panel is external. Click to bring to front.")))
(set-geometry msg :units "%" :height 100 :width 100) (set-geometry msg :units "%" :height 100 :width 100)
@ -613,11 +614,11 @@ not a temporarily attached one when using select-control."
(focus pop-win)))) (focus pop-win))))
(setf ext-panel pop) (setf ext-panel pop)
(cond ((eq open-ext :custom) (cond ((eq open-ext :custom)
(load-css (html-document pop) "/css/jquery-ui.css") (load-css (html-document pop) "/css/jquery-ui.css")
(load-script (html-document pop) "/js/jquery-ui.js")) (load-script (html-document pop) "/js/jquery-ui.js"))
(t (t
(clog-gui-initialize pop) (clog-gui-initialize pop)
(clog-web-initialize pop :w3-css-url nil))) (clog-web-initialize pop :w3-css-url nil)))
(setf (connection-data-item pop "builder-app-data") app) (setf (connection-data-item pop "builder-app-data") app)
(let ((nbox (create-panel-box-layout pop (let ((nbox (create-panel-box-layout pop
:left-width 0 :right-width 0 :left-width 0 :right-width 0
@ -645,18 +646,18 @@ not a temporarily attached one when using select-control."
(lambda (filename) (lambda (filename)
(when filename (when filename
(maphash (maphash
(lambda (html-id control) (lambda (html-id control)
(declare (ignore html-id)) (declare (ignore html-id))
(place-inside-bottom-of (bottom-panel box) (place-inside-bottom-of (bottom-panel box)
(get-placer control))) (get-placer control)))
(get-control-list app panel-id)) (get-control-list app panel-id))
;; needs to clear data attrs ;; needs to clear data attrs
(save-body-to-file filename :body pop :if-exists :rename) (save-body-to-file filename :body pop :if-exists :rename)
(maphash (maphash
(lambda (html-id control) (lambda (html-id control)
(declare (ignore html-id)) (declare (ignore html-id))
(place-after control (get-placer control))) (place-after control (get-placer control)))
(get-control-list app panel-id))))))) (get-control-list app panel-id)))))))
(focus pop-win))))) (focus pop-win)))))
(setf-next-id content 1) (setf-next-id content 1)
(setf (css-class-name content) *builder-panel-class*) (setf (css-class-name content) *builder-panel-class*)
@ -709,108 +710,107 @@ not a temporarily attached one when using select-control."
(set-on-click m-helpk 'on-quick-start) (set-on-click m-helpk 'on-quick-start)
(labels (;; copy (labels (;; copy
(copy (obj) (copy (obj)
(when (current-control app) (when (current-control app)
(maphash (maphash
(lambda (html-id control) (lambda (html-id control)
(declare (ignore html-id)) (declare (ignore html-id))
(place-inside-bottom-of (bottom-panel box) (place-inside-bottom-of (bottom-panel box)
(get-placer control))) (get-placer control)))
(get-control-list app panel-id)) (get-control-list app panel-id))
(setf (copy-buf app) (setf (copy-buf app)
(js-query content (js-query content
(format nil (format nil
"var z=~a.clone(); z=$('<div />').append(z);~ "var z=~a.clone(); z=$('<div />').append(z);~
z.find('*').each(function(){~ z.find('*').each(function(){~
if($(this).attr('data-clog-composite-control') == 't'){$(this).text('')}~ if($(this).attr('data-clog-composite-control') == 't'){$(this).text('')}~
if($(this).attr('id') !== undefined && ~ if($(this).attr('id') !== undefined && ~
$(this).attr('id').substring(0,5)=='CLOGB'){$(this).removeAttr('id')}});~ $(this).attr('id').substring(0,5)=='CLOGB'){$(this).removeAttr('id')}});~
z.html()" z.html()"
(jquery (current-control app))))) (jquery (current-control app)))))
(system-clipboard-write obj (copy-buf app)) (system-clipboard-write obj (copy-buf app))
(let ((c (create-text-area (window-content (copy-history-win app)) (let ((c (create-text-area (window-content (copy-history-win app))
:value (copy-buf app) :value (copy-buf app)
:class "w3-input" :class "w3-input")))
:auto-place nil))) (place-inside-top-of (window-content (copy-history-win app)) c))
(place-inside-top-of (window-content (copy-history-win app)) c)) (maphash
(maphash (lambda (html-id control)
(lambda (html-id control) (declare (ignore html-id))
(declare (ignore html-id)) (place-after control (get-placer control)))
(place-after control (get-placer control))) (get-control-list app panel-id))))
(get-control-list app panel-id))))
;; paste ;; paste
(paste (obj) (paste (obj)
(let ((buf (or (system-clipboard-read obj) (let ((buf (or (system-clipboard-read obj)
(copy-buf app)))) (copy-buf app))))
(when buf (when buf
(let ((control (create-control content content (let ((control (create-control content content
`(:name "custom" `(:name "custom"
:create-type :paste) :create-type :paste)
(format nil "CLOGB~A~A" (format nil "CLOGB~A~A"
(get-universal-time) (get-universal-time)
(next-id content)) (next-id content))
:custom-query buf))) :custom-query buf)))
(setf (attribute control "data-clog-name") (setf (attribute control "data-clog-name")
(format nil "~A-~A" "copy" (next-id content))) (format nil "~A-~A" "copy" (next-id content)))
(incf-next-id content) (incf-next-id content)
(add-sub-controls control content :win win :paste t) (add-sub-controls control content :win win :paste t)
(let ((cr (control-info (attribute control "data-clog-type")))) (let ((cr (control-info (attribute control "data-clog-type"))))
(when (getf cr :on-load) (when (getf cr :on-load)
(funcall (getf cr :on-load) control cr))) (funcall (getf cr :on-load) control cr)))
(setup-control content control :win win) (setup-control content control :win win)
(select-control control) (select-control control)
(on-populate-control-list-win content :win win) (on-populate-control-list-win content :win win)
(jquery-execute (get-placer content) "trigger('clog-builder-snap-shot')"))))) (jquery-execute (get-placer content) "trigger('clog-builder-snap-shot')")))))
;; delete ;; delete
(del (obj) (del (obj)
(declare (ignore obj)) (declare (ignore obj))
(when (current-control app) (when (current-control app)
(delete-current-control app panel-id (html-id (current-control app))) (delete-current-control app panel-id (html-id (current-control app)))
(on-populate-control-properties-win content :win win) (on-populate-control-properties-win content :win win)
(on-populate-control-list-win content :win win) (on-populate-control-list-win content :win win)
(jquery-execute (get-placer content) "trigger('clog-builder-snap-shot')"))) (jquery-execute (get-placer content) "trigger('clog-builder-snap-shot')")))
(cut (obj) (cut (obj)
(copy obj) (copy obj)
(del obj)) (del obj))
(undo (obj) (undo (obj)
(declare (ignore obj)) (declare (ignore obj))
(when undo-chain (when undo-chain
(setf (inner-html content) (setf (inner-html content)
(let ((val (pop undo-chain))) (let ((val (pop undo-chain)))
(push val redo-chain) (push val redo-chain)
val)) val))
(clrhash (get-control-list app panel-id)) (clrhash (get-control-list app panel-id))
(on-populate-loaded-window content :win win) (on-populate-loaded-window content :win win)
(setf (window-title win) (attribute content "data-clog-name")) (setf (window-title win) (attribute content "data-clog-name"))
(on-populate-control-properties-win content :win win) (on-populate-control-properties-win content :win win)
(on-populate-control-list-win content :win win))) (on-populate-control-list-win content :win win)))
(redo (obj) (redo (obj)
(declare (ignore obj)) (declare (ignore obj))
(when redo-chain (when redo-chain
(setf (inner-html content) (setf (inner-html content)
(let ((val (pop redo-chain))) (let ((val (pop redo-chain)))
(push val undo-chain) (push val undo-chain)
val)) val))
(clrhash (get-control-list app panel-id)) (clrhash (get-control-list app panel-id))
(on-populate-loaded-window content :win win) (on-populate-loaded-window content :win win)
(setf (window-title win) (attribute content "data-clog-name")) (setf (window-title win) (attribute content "data-clog-name"))
(on-populate-control-properties-win content :win win) (on-populate-control-properties-win content :win win)
(on-populate-control-list-win content :win win)))) (on-populate-control-list-win content :win win))))
;; set up del/cut/copy/paste handlers ;; set up del/cut/copy/paste handlers
;;(set-on-click btn-undo #'undo) ;;(set-on-click btn-undo #'undo)
;;(set-on-click m-undo #'undo) ;;(set-on-click m-undo #'undo)
;;(set-on-click btn-redo #'redo) ;;(set-on-click btn-redo #'redo)
;;(set-on-click m-redo #'redo) ;;(set-on-click m-redo #'redo)
(set-on-copy content #'copy) (set-on-copy content #'copy)
(set-on-click btn-copy #'copy) (set-on-click btn-copy #'copy)
(set-on-click m-copy #'copy) (set-on-click m-copy #'copy)
(set-on-paste content #'paste) (set-on-paste content #'paste)
(set-on-click btn-paste #'paste) (set-on-click btn-paste #'paste)
(set-on-click m-paste #'paste) (set-on-click m-paste #'paste)
(set-on-click btn-del #'del) (set-on-click btn-del #'del)
(set-on-click m-del #'del) (set-on-click m-del #'del)
(set-on-cut content #'cut) (set-on-cut content #'cut)
(set-on-click btn-cut #'cut) (set-on-click btn-cut #'cut)
(set-on-click m-cut #'cut)) (set-on-click m-cut #'cut))
(labels ((open-file-name (fname) (labels ((open-file-name (fname)
(setf file-name fname) (setf file-name fname)
(setf last-date (file-write-date fname)) (setf last-date (file-write-date fname))
@ -858,79 +858,79 @@ not a temporarily attached one when using select-control."
(sleep .5) (sleep .5)
(remove-class btn-save "w3-animate-top") (remove-class btn-save "w3-animate-top")
(cond ((eq is-dirty :close) (cond ((eq is-dirty :close)
(setf is-dirty nil) (setf is-dirty nil)
(window-close win)) (window-close win))
(t (t
(setf is-dirty nil)))) (setf is-dirty nil))))
(save (obj data &key save-as) (save (obj data &key save-as)
(cond ((or (equal file-name "") (cond ((or (equal file-name "")
save-as save-as
(getf data :shift-key)) (getf data :shift-key))
(when (equal file-name "") (when (equal file-name "")
(setf file-name (format nil "~A~A.clog" (setf file-name (format nil "~A~A.clog"
(current-project-dir app) (current-project-dir app)
(attribute content "data-clog-name")))) (attribute content "data-clog-name"))))
(server-file-dialog obj "Save Panel As.." file-name (server-file-dialog obj "Save Panel As.." file-name
(lambda (fname) (lambda (fname)
(window-focus win) (window-focus win)
(when fname (when fname
(setf file-name fname) (setf file-name fname)
(do-save obj fname data))) (do-save obj fname data)))
:initial-filename file-name)) :initial-filename file-name))
(t (t
(if (eql last-date (file-write-date file-name)) (if (eql last-date (file-write-date file-name))
(do-save obj file-name data) (do-save obj file-name data)
(confirm-dialog obj "Panel changed on file system. Save?" (confirm-dialog obj "Panel changed on file system. Save?"
(lambda (result) (lambda (result)
(when result (when result
(do-save obj file-name data)))))))) (do-save obj file-name data))))))))
(eval-test (obj &key (test t)) (eval-test (obj &key (test t))
(do-eval obj (render-clog-code content (bottom-panel box)) (do-eval obj (render-clog-code content (bottom-panel box))
(attribute content "data-clog-name") (attribute content "data-clog-name")
:test test :test test
:package (attribute content "data-in-package"))) :package (attribute content "data-in-package")))
(render (obj data &key save-as) (render (obj data &key save-as)
(cond ((or (equal render-file-name "") (cond ((or (equal render-file-name "")
save-as save-as
(getf data :shift-key)) (getf data :shift-key))
(when (equal render-file-name "") (when (equal render-file-name "")
(if (equal file-name "") (if (equal file-name "")
(setf render-file-name (format nil "~A.lisp" (attribute content "data-clog-name"))) (setf render-file-name (format nil "~A.lisp" (attribute content "data-clog-name")))
(setf render-file-name (format nil "~A~A.lisp" (setf render-file-name (format nil "~A~A.lisp"
(directory-namestring file-name) (directory-namestring file-name)
(pathname-name file-name))))) (pathname-name file-name)))))
(server-file-dialog obj "Render As.." render-file-name (server-file-dialog obj "Render As.." render-file-name
(lambda (fname) (lambda (fname)
(window-focus win) (window-focus win)
(when fname (when fname
(setf render-file-name fname) (setf render-file-name fname)
(add-class btn-rndr "w3-animate-top") (add-class btn-rndr "w3-animate-top")
(write-file (render-clog-code content (bottom-panel box)) (write-file (render-clog-code content (bottom-panel box))
fname :clog-obj obj) fname :clog-obj obj)
(sleep .5) (sleep .5)
(remove-class btn-rndr "w3-animate-top"))) (remove-class btn-rndr "w3-animate-top")))
:initial-filename render-file-name)) :initial-filename render-file-name))
(t (t
(add-class btn-rndr "w3-animate-top") (add-class btn-rndr "w3-animate-top")
(write-file (render-clog-code content (bottom-panel box)) (write-file (render-clog-code content (bottom-panel box))
render-file-name :clog-obj obj) render-file-name :clog-obj obj)
(sleep .5) (sleep .5)
(remove-class btn-rndr "w3-animate-top"))))) (remove-class btn-rndr "w3-animate-top")))))
(set-on-window-can-close win (set-on-window-can-close win
(lambda (obj) (lambda (obj)
(cond (is-dirty (cond (is-dirty
(confirm-dialog win "Save panel?" (confirm-dialog win "Save panel?"
(lambda (result) (lambda (result)
(cond (result (cond (result
(setf is-dirty :close) (setf is-dirty :close)
(save obj nil)) (save obj nil))
(t (t
(setf is-dirty nil) (setf is-dirty nil)
(window-close win)))) (window-close win))))
:ok-text "Yes" :cancel-text "No") :ok-text "Yes" :cancel-text "No")
nil) nil)
(t (t
t)))) t))))
(set-on-mouse-click btn-save (set-on-mouse-click btn-save
(lambda (obj data) (lambda (obj data)
(save obj data))) (save obj data)))
@ -1005,6 +1005,6 @@ not a temporarily attached one when using select-control."
(let* ((*default-title-class* *builder-title-class*) (let* ((*default-title-class* *builder-title-class*)
(*default-border-class* *builder-border-class*) (*default-border-class* *builder-border-class*)
(win (create-gui-window obj :title "Quick Start" (win (create-gui-window obj :title "Quick Start"
:width 600 :height 400 :width 600 :height 400
:client-movement *client-side-movement*))) :client-movement *client-side-movement*)))
(create-quick-start (window-content win)))) (create-quick-start (window-content win))))