;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; CLOG - The Common Lisp Omnificent GUI ;;;; ;;;; (c) 2020-2021 David Botton ;;;; ;;;; License BSD 3 Clause ;;;; ;;;; ;;;; ;;;; clog-gui.lisp ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cl:in-package :clog) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Implementation - clog-gui - Desktop GUI abstraction ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defconstant menu-bar-height 37) (defconstant top-bar-height 20) (defclass clog-gui () ((body :accessor body :documentation "Top level access to browser window") (current-win :accessor current-win :initform nil :documentation "The current window at front") (windows :accessor windows :initform (make-hash-table :test 'equalp) :documentation "Window collection indexed by html-id") (last-z :accessor last-z :initform -9999 :documentation "Top z-order for windows") (last-x :accessor last-x :initform 0 :documentation "Last default open x point") (last-y :accessor last-y :initform menu-bar-height :documentation "Last default open y point") (copy-buf :accessor copy-buf :initform "" :documentation "Copy buffer") (in-drag :accessor in-drag :initform nil :documentation "Drag window or Size window") (drag-obj :accessor drag-obj :initform nil :documentation "Drag target object") (drag-x :accessor drag-x :documentation "Location of the left side or width relative to pointer during drag") (drag-y :accessor drag-y :documentation "Location of the top or height relative to pointer during drag") (window-select :accessor window-select :initform nil :documentation "If installed a drop down that selects window to maximize") (on-window-change :accessor on-window-change :initform nil :documentation "Fired when foreground window changed."))) ;;;;;;;;;;;;;;;;;;;;; ;; create-clog-gui ;; ;;;;;;;;;;;;;;;;;;;;; (defun create-clog-gui (clog-body) "Create a clog-gui object and places it in CLOG-BODY's connection-data as \"clog-gui\". (Private)" (let ((clog-gui (make-instance 'clog-gui))) (setf (connection-data-item clog-body "clog-gui") clog-gui) (setf (body clog-gui) clog-body) clog-gui)) ;;;;;;;;;;;;;;;;;;;;;;;;; ;; clog-gui-initialize ;; ;;;;;;;;;;;;;;;;;;;;;;;;; (defun clog-gui-initialize (clog-body &key (w3-css-url "/css/w3.css") (jquery-ui-css "/css/jquery-ui.css") (jquery-ui "/js/jquery-ui.js")) "Initializes clog-gui and installs a clog-gui object on connection." (create-clog-gui clog-body) (set-on-full-screen-change (html-document clog-body) (lambda (obj) (when (current-window obj) (when (last-width (current-window obj)) (window-normalize (current-window obj)) (window-maximize (current-window obj)))))) (set-on-orientation-change (window clog-body) (lambda (obj) (when (current-window obj) (when (last-width (current-window obj)) (window-normalize (current-window obj)) (window-maximize (current-window obj)))))) (when w3-css-url (load-css (html-document clog-body) w3-css-url)) (when jquery-ui-css (load-css (html-document clog-body) jquery-ui-css)) (when jquery-ui (load-script (html-document clog-body) jquery-ui))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Implementation - Menus ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;; ;; create-gui-menu-bar ;; ;;;;;;;;;;;;;;;;;;;;;;;;; (defclass clog-gui-menu-bar (clog-div)() (:documentation "Menu bar")) (defgeneric create-gui-menu-bar (clog-obj &key class html-id) (:documentation "Attached a menu bar to a CLOG-OBJ in general a clog-body.")) (defmethod create-gui-menu-bar ((obj clog-obj) &key (class "w3-bar w3-black w3-card-4") (html-id nil)) (let ((div (create-div obj :class class :html-id html-id))) (change-class div 'clog-gui-menu-bar))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; create-gui-menu-drop-down ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass clog-gui-menu-drop-down (clog-div)() (:documentation "Drop down menu")) (defgeneric create-gui-menu-drop-down (clog-gui-menu-bar &key content class html-id) (:documentation "Attached a menu bar drop-down to a CLOG-GUI-MENU-BAR")) (defmethod create-gui-menu-drop-down ((obj clog-gui-menu-bar) &key (content "") (class "w3-dropdown-content w3-bar-block w3-card-4") (html-id nil)) (let* ((hover (create-div obj :class "w3-dropdown-hover")) (button (create-button hover :class "w3-button" :content content)) (div (create-div hover :class class :html-id html-id))) (declare (ignore button)) (change-class div 'clog-gui-menu-drop-down))) ;;;;;;;;;;;;;;;;;;;;;;;;;; ;; create-gui-menu-item ;; ;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass clog-gui-menu-item (clog-span)() (:documentation "Menu item")) (defgeneric create-gui-menu-item (clog-gui-menu-drop-down &key content on-click class html-id) (:documentation "Attached a menu item to a CLOG-GUI-MENU-DROP-DOWN")) (defmethod create-gui-menu-item ((obj clog-obj) &key (content "") (on-click nil) (class "w3-bar-item w3-button") (html-id nil)) (let ((span (create-span obj :content content :class class :html-id html-id))) (set-on-click span on-click) (change-class span 'clog-gui-menu-item))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; create-gui-menu-window-select ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass clog-gui-menu-window-select (clog-select)() (:documentation "Drop down containing windows. Selecting a window will maximize it on top.")) (defgeneric create-gui-menu-window-select (clog-gui-menu-drop-down &key class html-id) (:documentation "Attached a menu item to a CLOG-GUI-MENU-DROP-DOWN")) (defmethod create-gui-menu-window-select ((obj clog-obj) &key (class "w3-select") (html-id nil)) (let ((window-select (create-select obj :class class :html-id html-id)) (app (connection-data-item obj "clog-gui"))) (change-class window-select 'clog-gui-menu-window-select) (setf (window-select app) window-select) (set-on-change window-select (lambda (obj) (let ((win (gethash (value obj) (windows app)))) (when win (window-maximize win))))) (create-option window-select :content "Select Window") window-select)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; create-gui-menu-full-screen ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgeneric create-gui-menu-full-screen (clog-gui-menu-bar &key html-id) (:documentation "Add as last item in menu bar to allow for a full screen icon ⤢ and full screen mode.")) (defmethod create-gui-menu-full-screen ((obj clog-gui-menu-bar) &key (html-id nil)) (create-child obj " " :html-id html-id :clog-type 'clog-gui-menu-item)) ;;;;;;;;;;;;;;;;;;;;;;;;;; ;; create-gui-menu-icon ;; ;;;;;;;;;;;;;;;;;;;;;;;;;; (defgeneric create-gui-menu-icon (clog-gui-menu-bar &key image-url on-click class html-id) (:documentation "Add icon as menu bar item.")) (defmethod create-gui-menu-icon ((obj clog-gui-menu-bar) &key (image-url "/img/clogwicon.png") (on-click nil) (class "w3-button w3-bar-item") (html-id nil)) (set-on-click (create-child obj (format nil "" class image-url) :html-id html-id :clog-type 'clog-gui-menu-item) on-click)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Implementation - Window System ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;; ;; current-window ;; ;;;;;;;;;;;;;;;;;;;; (defgeneric current-window (clog-obj) (:documentation "Get the current selected clog-gui-window")) (defmethod current-window ((obj clog-obj)) (let ((app (connection-data-item obj "clog-gui"))) (current-win app))) ;;;;;;;;;;;;;;;;;;;;;;;;;; ;; set-on-window-change ;; ;;;;;;;;;;;;;;;;;;;;;;;;;; (defgeneric set-on-window-change (clog-obj handler) (:documentation "Set the on-window-change HANDLER. The on-window-change clog-obj received is the new window")) (defmethod set-on-window-change ((obj clog-obj) handler) (let ((app (connection-data-item obj "clog-gui"))) (setf (on-window-change app) handler))) (defmethod fire-on-window-change (obj app) "Fire handler if set. Change the value of current-win to clog-obj (Private)" (unless obj (let (new-order (order -9999)) (maphash (lambda (key value) (declare (ignore key)) (setf new-order (z-index value)) (when (>= new-order order) (setf order new-order) (setf obj value))) (windows app)))) (setf (current-win app) obj) (when (on-window-change app) (funcall (on-window-change app) obj))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Implementation - Individual Windows ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass clog-gui-window (clog-element) ((win-title :accessor win-title :documentation "Window title clog-element") (title-bar :accessor title-bar :documentation "Window title-bar clog-element") (content :accessor content :documentation "Window body clog-element") (closer :accessor closer :documentation "Window closer clog-element") (sizer :accessor sizer :documentation "Window sizer clog-element") (last-width :accessor last-width :initform nil :documentation "Last width before maximize") (last-height :accessor last-height :initform nil :documentation "Last heigth before maximize") (last-x :accessor last-x :initform nil :documentation "Last x before maximize") (last-y :accessor last-y :initform nil :documentation "Last y before maximize") (window-select-item :accessor window-select-item :initform nil :documentation "Item in window select") (on-window-can-close :accessor on-window-can-close :initform nil :documentation "Return t to allow close of window") (on-window-can-move :accessor on-window-can-move :initform nil :documentation "Return t to allow move of window") (on-window-can-size :accessor on-window-can-size :initform nil :documentation "Return t to allow close of window") (on-window-close :accessor on-window-close :initform nil :documentation "Fired on window closed") (on-window-move :accessor on-window-move :initform nil :documentation "Fired during move of window") (on-window-size :accessor on-window-size :initform nil :documentation "Fired during size change of window") (on-window-move-done :accessor on-window-move-done :initform nil :documentation "Fired after move of window") (on-window-size-done :accessor on-window-size-done :initform nil :documentation "Fired after size change of window"))) ;;;;;;;;;;;;;;;;;;;;;; ;; on-gui-drag-down ;; ;;;;;;;;;;;;;;;;;;;;;; (defun on-gui-drag-down (obj data) "Handle mouse down on drag items" (let ((app (connection-data-item obj "clog-gui"))) (unless (in-drag app) (setf (in-drag app) (attribute obj "data-drag-type")) (let* ((target (gethash (attribute obj "data-drag-obj") (windows app))) (pointer-x (getf data ':screen-x)) (pointer-y (getf data ':screen-y)) (obj-top) (obj-left) (perform-drag nil)) (when target (setf (drag-obj app) target) (cond ((equalp (in-drag app) "m") (setf obj-top (parse-integer (top (drag-obj app)) :junk-allowed t)) (setf obj-left (parse-integer (left (drag-obj app)) :junk-allowed t)) (setf perform-drag (fire-on-window-can-move (drag-obj app)))) ((equalp (in-drag app) "s") (setf obj-top (height (drag-obj app))) (setf obj-left (width (drag-obj app))) (setf perform-drag (fire-on-window-can-size (drag-obj app)))) (t (format t "Warning - invalid data-drag-type attribute"))) (setf (z-index (drag-obj app)) (incf (last-z app))) (fire-on-window-change (drag-obj app) app) (setf (drag-y app) (- pointer-y obj-top)) (setf (drag-x app) (- pointer-x obj-left))) (cond (perform-drag (set-on-pointer-move obj 'on-gui-drag-move) (set-on-pointer-up obj 'on-gui-drag-stop)) (t (setf (in-drag app) nil))))))) ;;;;;;;;;;;;;;;;;;;;;; ;; on-gui-drag-move ;; ;;;;;;;;;;;;;;;;;;;;;; (defun on-gui-drag-move (obj data) "Handle mouse tracking on drag object" (let* ((app (connection-data-item obj "clog-gui")) (x (getf data ':screen-x)) (y (getf data ':screen-y)) (adj-y (- y (drag-y app))) (adj-x (- x (drag-x app)))) (when (and (> adj-x 0) (> adj-y menu-bar-height)) (cond ((equalp (in-drag app) "m") (fire-on-window-move (drag-obj app)) (setf (top (drag-obj app)) (unit :px adj-y)) (setf (left (drag-obj app)) (unit :px adj-x))) ((equalp (in-drag app) "s") (fire-on-window-size (drag-obj app)) (setf (height (drag-obj app)) (unit :px adj-y)) (setf (width (drag-obj app)) (unit :px adj-x))))))) ;;;;;;;;;;;;;;;;;;;;;; ;; on-gui-drag-stop ;; ;;;;;;;;;;;;;;;;;;;;;; (defun on-gui-drag-stop (obj data) "Handle end of drag object" (let ((app (connection-data-item obj "clog-gui"))) (on-gui-drag-move obj data) (set-on-pointer-move obj nil) (set-on-pointer-up obj nil) (cond ((equalp (in-drag app) "m") (fire-on-window-move-done (drag-obj app))) ((equalp (in-drag app) "s") (fire-on-window-size-done (drag-obj app)))) (setf (in-drag app) nil) (setf (drag-obj app) nil))) ;;;;;;;;;;;;;;;;;;;;;;; ;; create-gui-window ;; ;;;;;;;;;;;;;;;;;;;;;;; (defgeneric create-gui-window (clog-obj &key title content left top width height maximize client-movement html-id) (:documentation "Create a clog-gui-window. If client-movement is t then use jquery-ui to move/resize and will not work on mobile. When client-movement is t only on-window-move is fired once at start of drag and on-window-move-done at end of drag and on-window-resize at start of resize and on-window-resize-done at end of resize.")) (defmethod create-gui-window ((obj clog-obj) &key (title "New Window") (content "") (left nil) (top nil) (width 300) (height 200) (maximize nil) (client-movement nil) (html-id nil)) (let ((app (connection-data-item obj "clog-gui"))) (unless html-id (setf html-id (clog-connection:generate-id))) (unless left (setf left (last-x app)) (incf (last-x app) 10)) (unless top (setf top (last-y app)) (incf (last-y app) top-bar-height) (when (> top (- (inner-height (window (body app))) (last-y app))) (setf (last-y app) menu-bar-height))) (let ((win (create-child (body app) (format nil "