;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; CLOG - The Common Lisp Omnificent GUI                                 ;;;;
;;;; (c) David Botton                                                      ;;;;
;;;;                                                                       ;;;;
;;;; clog-gui.lisp                                                         ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Like clog-web, clog-gui uses w3.css as the underlying framework. w3.css is
;;; a public domain css only framework for layouts, is fast and efficient and
;;; does not require additional components outside of the css file. In addition
;;; clog-gui uses jQueryUI and its default css file to provide client side
;;; movement when needed, if client side movement is not used it is possible
;;; to pass nil to the initilization function for both the js and css.

(mgl-pax:define-package :clog-gui
  (:documentation "CLOG-GUI a desktop GUI abstraction for CLOG")
  (:use #:cl #:clog #:mgl-pax))

(cl:in-package :clog-gui)

(defsection @clog-gui (:title "CLOG GUI Objects")
  "CLOG-GUI - Desktop GUI abstraction for CLOG"
  (clog-gui-initialize function)

  "CLOG-GUI - Menus"
  (clog-gui-menu-bar             class)
  (create-gui-menu-bar           generic-function)
  (clog-gui-menu-drop-down       class)
  (create-gui-menu-drop-down     generic-function)
  (clog-gui-menu-item            class)
  (create-gui-menu-item          generic-function)
  (create-gui-menu-window-select generic-function)
  (create-gui-menu-full-screen   generic-function)
  (create-gui-menu-icon          generic-function)

  "CLOG-GUI - Window System"
  (current-window              generic-function)
  (menu-bar                    generic-function)
  (menu-bar-height             generic-function)
  (window-collection           generic-function)
  (window-to-top-by-title      generic-function)
  (window-to-top-by-param      generic-function)
  (window-by-title             generic-function)
  (window-by-param             generic-function)
  (reorient-all-windows        generic-function)
  (maximize-all-windows        generic-function)
  (normalize-all-windows       generic-function)
  (set-on-window-change        generic-function)

  "CLOG-GUI - Individual Windows"
  (clog-gui-window             class)
  (create-gui-window           generic-function)
  (window-title                generic-function)
  (window-param                generic-function)
  (window-content              generic-function)
  (window-focus                generic-function)
  (window-close                generic-function)
  (window-maximized-p          generic-function)
  (window-maximize             generic-function)
  (window-normalize            generic-function)
  (window-toggle-maximize      generic-function)
  (window-toggle-pinned        generic-function)
  (window-keep-on-top          generic-function)
  (window-make-modal           generic-function)
  (window-end-modal            generic-function)
  (window-center               generic-function)

  "CLOG-GUI - Individual Window Events"
  (set-on-window-focus         generic-function)
  (set-on-window-blur          generic-function)
  (set-on-window-can-close     generic-function)
  (set-on-window-close         generic-function)
  (set-on-window-can-maximize  generic-function)
  (set-on-window-can-normalize generic-function)
  (set-on-window-can-move      generic-function)
  (set-on-window-can-size      generic-function)
  (set-on-window-move          generic-function)
  (set-on-window-size          generic-function)
  (set-on-window-move-done     generic-function)
  (set-on-window-size-done     generic-function)

  "CLOG-GUI - Dialog Boxes"
  (alert-toast                 function)
  (alert-dialog                function)
  (input-dialog                function)
  (confirm-dialog              function)
  (form-dialog                 function)
  (server-file-dialog          function)
  (one-of-dialog               function)
  (dialog-in-stream            class)
  (dialog-out-stream           class)

  "CLOG-GUI - Debugger"
  (with-clog-debugger macro)

  "CLOG-GUI - Look and Feel"
  (*menu-bar-class*           variable)
  (*menu-bar-drop-down-class* variable)
  (*menu-item-class*          variable)
  (*menu-window-select-class* variable)
  (*menu-full-screen-item*    variable)
  (*menu-icon-image-class*    variable)
  (*top-bar-height*           variable)
  (*default-title-class*      variable)
  (*default-border-class*     variable))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Default Settings
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Menus
(defparameter *menu-bar-class* "w3-bar w3-black w3-card-4")
(defparameter *menu-bar-drop-down-class* "w3-dropdown-content w3-bar-block w3-card-4")
(defparameter *menu-item-class* "w3-bar-item w3-button")
(defparameter *menu-window-select-class* "w3-bar-item w3-button")
(defparameter *menu-full-screen-item* "⤢")
(defparameter *menu-icon-image-class* "w3-button w3-bar-item")

;; New Window placement
(defparameter *top-bar-height* 20
  "Overlap on new windows created with top set as nil")

;; Window treatements
(defparameter *default-title-class* "w3-black"
  "Window title bar class")
(defparameter *default-border-class* "w3-card-4 w3-white w3-border"
  "Window frame border")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - clog-gui - Desktop GUI abstraction
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(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")
   (body-left-offset
    :accessor body-left-offset
    :initform 0
    :documentation "Offset for maximize on left side")
   (body-right-offset
    :accessor body-right-offset
    :initform 0
    :documentation "Offset for maximize on right side")
   (last-y
    :accessor last-y
    :initform 0
    :documentation "Last default open y point")
   (modal-background
    :accessor modal-background
    :initform nil
    :documentation "Modal Background")
   (modal-count
    :accessor modal-count
    :initform 0
    :documentation "Count of nested modal windows")
   (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")
   (menu
    :accessor menu
    :initform nil
    :documentation "Installed menu bar if installed")
   (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))

;;;;;;;;;;;;;;;;;;;;;;;;
;; with-clog-debugger ;;
;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro with-clog-debugger ((clog-obj &key title) &body body)
  "body uses a clog-gui based debugged instead of the console"
  `(with-open-stream (out-stream (make-instance 'dialog-out-stream))
    (with-open-stream (in-stream (make-instance 'dialog-in-stream :clog-obj ,clog-obj :source out-stream))
      (labels ((my-debugger (condition encapsulation)
                 (ignore-errors
                  (let ((restart (one-of-dialog ,clog-obj condition (compute-restarts)
                                                :title (format nil "Available Restarts~A"
                                                               (if ,title
                                                                   (format nil " for ~A" ,title)
                                                                   "")))))
                    (when restart
                      (let ((*debugger-hook* encapsulation))
                        (invoke-restart-interactively restart)))))))
        (let* ((*query-io*      (make-two-way-stream in-stream out-stream))
               (*debugger-hook* (if clog-connection:*disable-clog-debugging*
                                    *debugger-hook*
                                    #'my-debugger)))
          ,@body)))))

;;;;;;;;;;;;;;;;;;;;;;;;;
;; clog-gui-initialize ;;
;;;;;;;;;;;;;;;;;;;;;;;;;

(defun clog-gui-initialize (clog-body &key
                                        (body-left-offset 0)
                                        (body-right-offset 0)
                                        (use-clog-debugger nil)
                                        (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.
If W3-CSS-URL has not been loaded before is installed unless is nil.
BODY-LEFT-OFFSET and BODY-RIGHT-OFFSET limit width on maximize. If
use-clog-debugger then a graphical debugger is set for all events.
NOTE: use-clog-debugger should not be set for security issues
      on non-secure environments."
  (let ((app (create-clog-gui clog-body)))
    (setf (body-left-offset app) body-left-offset)
    (setf (body-right-offset app) body-right-offset))
  (set-on-full-screen-change (html-document clog-body) 'reorient-all-windows)
  (set-on-orientation-change (window clog-body) 'reorient-all-windows)
  (set-on-resize (window clog-body) 'reorient-all-windows)
  (unless (connection-data-item clog-body "w3-css")
    (when w3-css-url
      (setf (connection-data-item clog-body "w3-css") t)
      (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))
  (when (and use-clog-debugger (not clog-connection:*disable-clog-debugging*))
    (setf (connection-data-item clog-body "clog-debug") (lambda (event data)
                                                          (with-clog-debugger (clog-body)
                                                            (funcall event data))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - Menus
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;
;; menu-bar ;;
;;;;;;;;;;;;;;

(defgeneric menu-bar (clog-obj)
  (:documentation "Get/setf window menu-bar. This is set buy
create-gui-menu-bar."))

(defmethod menu-bar ((obj clog-obj))
  (let ((app (connection-data-item obj "clog-gui")))
    (menu app)))

(defgeneric (setf menu-bar) (value clog-obj)
  (:documentation "Set window menu-bar"))

(defmethod (setf menu-bar) (value (obj clog-obj))
  (let ((app (connection-data-item obj "clog-gui")))
    (setf (menu app) value)))

;;;;;;;;;;;;;;;;;;;;;
;; menu-bar-height ;;
;;;;;;;;;;;;;;;;;;;;;

(defgeneric menu-bar-height (clog-obj)
  (:documentation "Get menu-bar height"))

(defmethod menu-bar-height ((obj clog-obj))
  (let ((app (connection-data-item obj "clog-gui")))
    (if (menu app)
        (height (menu app))
        0)))

;;;;;;;;;;;;;;;;;;;;;;;
;; window-collection ;;
;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric window-collection (clog-obj)
  (:documentation "Get hash table of open windows"))

(defmethod window-collection ((obj clog-obj))
  (let ((app (connection-data-item obj "clog-gui")))
    (windows app)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; window-to-top-by-title ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric window-to-top-by-title (clog-obj title)
  (:documentation "Bring window with TITLE to top and return
window or nil if not found"))

(defmethod window-to-top-by-title ((obj clog-obj) title)
  (let ((app (connection-data-item obj "clog-gui"))
        (r   nil))
    (maphash (lambda (key value)
               (declare (ignore key))
               (when (equalp (window-title value) title)
                 (window-focus value)
                 (setf r value)))
             (windows app))
    r))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; window-to-top-by-param ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric window-to-top-by-param (clog-obj param)
  (:documentation "Bring window with PARAM to top and return
window or nil if not found"))

(defmethod window-to-top-by-param ((obj clog-obj) param)
  (let ((app (connection-data-item obj "clog-gui"))
        (r   nil))
    (maphash (lambda (key value)
               (declare (ignore key))
               (when (equalp (win-param value) param)
                 (window-focus value)
                 (setf r value)))
             (windows app))
    r))

;;;;;;;;;;;;;;;;;;;;;
;; window-by-title ;;
;;;;;;;;;;;;;;;;;;;;;

(defgeneric window-by-title (clog-obj title)
  (:documentation "Bring window with TITLE to top and return
window or nil if not found"))

(defmethod window-by-title ((obj clog-obj) title)
  (let ((app (connection-data-item obj "clog-gui"))
        (r   nil))
    (maphash (lambda (key value)
               (declare (ignore key))
               (when (equalp (window-title value) title)
                 (setf r value)))
             (windows app))
    r))

;;;;;;;;;;;;;;;;;;;;;
;; window-by-param ;;
;;;;;;;;;;;;;;;;;;;;;

(defgeneric window-by-param (clog-obj param)
  (:documentation "Bring window with PARAM to top and return
window or nil if not found"))

(defmethod window-by-param ((obj clog-obj) param)
  (let ((app (connection-data-item obj "clog-gui"))
        (r   nil))
    (maphash (lambda (key value)
               (declare (ignore key))
               (when (equalp (win-param value) param)
                 (setf r value)))
             (windows app))
    r))

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; maximize-all-windows ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric maximize-all-windows (clog-obj)
  (:documentation "Maximize all windows"))

(defmethod maximize-all-windows ((obj clog-obj))
  (let ((app (connection-data-item obj "clog-gui")))
    (maphash (lambda (key value)
               (declare (ignore key))
               (window-maximize value))
             (windows app))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; normalize-all-windows ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric normalize-all-windows (clog-obj)
  (:documentation "Normalize all windows"))

(defmethod normalize-all-windows ((obj clog-obj))
  (let ((app (connection-data-item obj "clog-gui")))
    (maphash (lambda (key value)
               (declare (ignore key))
               (window-normalize value))
             (windows app))))

;;;;;;;;;;;;;;;;;;;;
;; make-in-bounds ;;
;;;;;;;;;;;;;;;;;;;;

(defun make-in-bounds (obj mbh bh bw)
  "Insure obj in bounds of gui (private)"
  (let* ((top-loc   (js-to-integer (top obj)))
	 (left-loc  (js-to-integer (left obj)))
	 (width-loc (width obj)))
    (if (< (+ left-loc width-loc) 25)
	(setf (left obj) (unit :px (- 25 width-loc))))
    (if (> left-loc bw)
	(setf (left obj) (unit :px (- bw 15))))
    (if (< top-loc mbh)
	(setf (top obj) (unit :px mbh)))
    (if (>= top-loc bh)
	(setf (top obj) (unit :px (- bh 15))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; reorient-all-windows ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric reorient-all-windows (clog-obj)
  (:documentation "Reorient all windows. Remaximized any maximize windows
and leave any normalized windows as normalized. This is called by default
in on-resize, on-full-screen-change and on-orientation-change events."))

(defmethod reorient-all-windows ((obj clog-obj))
  (let* ((app  (connection-data-item obj "clog-gui"))
	 (body (connection-body obj))
	 (mbh  (menu-bar-height obj))
	 (bh   (height (html-document body)))
	 (bw   (width  (html-document body)))
	 (cur  (current-window obj)))
    (maphash (lambda (key value)
               (declare (ignore key))
               (cond ((window-maximized-p value)
                      (window-maximize value :focus nil))
		     (t
		      (make-in-bounds value mbh bh bw))))
             (windows app))
    (when cur
      (window-focus cur))))

;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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 main-menu)
  (:documentation "Attached a menu bar to a CLOG-OBJ in general a
clog-body. If main-menu add as main menu bar."))

(defmethod create-gui-menu-bar ((obj clog-obj)
                                &key (class *menu-bar-class*)
                                  (html-id nil)
                                  (main-menu t))
  (let* ((div (create-div obj :class class :html-id html-id))
         (blank (create-a div))
         (app (connection-data-item obj "clog-gui")))
    (declare (ignore blank))
    (change-class div 'clog-gui-menu-bar)
    (when main-menu
        (setf (menu app) div))
    div))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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 *menu-bar-drop-down-class*)
                    (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 *menu-item-class*)
                                   (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 existing windows."))

(defgeneric create-gui-menu-window-select (clog-obj
                                           &key class
                                             html-id)
  (:documentation "Attaches a clog-select as a menu item that auto updates
with open windows and focuses them unless is a keep-on-top window.
Only one instance allowed."))

(defmethod create-gui-menu-window-select
    ((obj clog-obj)
     &key (class *menu-window-select-class*)
       content
       (html-id nil))
  (let ((window-select (create-select obj :html-id html-id :class class))
        (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
                                       (unless (keep-on-top win)
                                         (setf (hiddenp win) nil)
                                         (window-focus win))))))
    (when content
      (create-option window-select :content content))
    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 ⤢ (*menu-full-screen-item* default) and full screen mode."))

(defmethod create-gui-menu-full-screen ((obj clog-gui-menu-bar)
                                        &key (html-id nil))
  (create-child obj
                (format nil
                        " <span class='w3-bar-item w3-right' style='user-select:none;'
                            onClick='if (document.fullscreenElement==null) {
                              documentElement.requestFullscreen()
                            } else {document.exitFullscreen();}'>~A</span>"
                        *menu-full-screen-item*)
          :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 *default-icon*)
                                   (on-click nil)
                                   (class *menu-icon-image-class*)
                                   (html-id nil))
  (set-on-click
   (create-child obj
                 (format nil "<button class='~A'>~
                                <img height=22 src='~A'></button>"
                         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 obj (Private)"
  (unless (eq obj (current-win app))
    (when (current-win app)
      (fire-on-window-blur (current-win app)))
    (unless obj
      (let (new-order
            (order -9999))
        (maphash (lambda (key value)
                   (declare (ignore key))
                   (setf new-order (z-index value))
                   (when (and new-order
                              (>= 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))
    (when obj
      (fire-on-window-focus obj))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - Individual Windows
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass clog-gui-window (clog-element)
  ((win-title
    :accessor win-title
    :documentation "Window title clog-element")
   (win-param
    :accessor win-param
    :initform nil
    :documentation "Window specific parameter")
   (title-bar
    :accessor title-bar
    :documentation "Window title-bar clog-element")
   (content
    :accessor content
    :documentation "Window body clog-element")
   (pinner
    :accessor pinner
    :initform nil
    :documentation "Window pinner clog-element if created with has-pinner")
   (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")
   (pinnedp
    :accessor pinnedp
    :initform nil
    :documentation "True if this window is pinned and nil otherwise")
   (keep-on-top
    :accessor keep-on-top
    :initform nil
    :documentation "If t don't change z-order")
   (window-size-mutex
    :reader window-size-mutex
    :initform (bordeaux-threads:make-lock)
    :documentation "Sync maximize / normalize events")
   (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 closing of window")
   (on-window-can-move
    :accessor on-window-can-move
    :initform nil
    :documentation "Return t to allow moving of window")
   (on-window-can-size
    :accessor on-window-can-size
    :initform nil
    :documentation "Return t to allow sizing of window")
   (on-window-can-maximize
    :accessor on-window-can-maximize
    :initform nil
    :documentation "Return t to allow maximizing of window")
   (on-window-can-normalize
    :accessor on-window-can-normalize
    :initform nil
    :documentation "Return t to allow normalizing of window")
   (on-window-focus
    :accessor on-window-focus
    :initform nil
    :documentation "Fired on window focused")
   (on-window-blur
    :accessor on-window-blur
    :initform nil
    :documentation "Fired on window blurred")
   (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
                       (js-to-integer (top (drag-obj app))))
                 (setf obj-left
                       (js-to-integer (left (drag-obj app))))
                 (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")))
          (unless (keep-on-top (drag-obj app))
            (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-cancel obj 'on-gui-drag-stop)
               (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))))
    (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-cancel obj nil)
    (set-on-pointer-up obj nil)
    (cond ((window-maximized-p (drag-obj app))
           (window-maximize (drag-obj app) :focus nil))
          (t
           (let* ((body      (connection-body (drag-obj app)))
                  (mbh       (menu-bar-height (drag-obj app)))
                  (bh        (height (html-document body)))
                  (bw        (width  (html-document body))))
      (make-in-bounds (drag-obj app) mbh bh bw))))
    (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
                                          has-pinner
                                          keep-on-top
                                          window-param
                                          hidden
                                          client-movement
                                          border-class
                                          title-class
                                          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 and touch events
are limitted to clicks. 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.
If has-pinner a toggle will appear on title bar to allow pinning the window in
place, if keep-on-top t then when pinned also will keep-on-top. If had-pinned
is nil and keep-on-top t then the window will be set to keep-on-top always.
window-param is a general parameter for identifiying the window to use with
window-to-top-by-param or window-by-param."))

(defmethod create-gui-window ((obj clog-obj) &key (title "New Window")
                                               (content "")
                                               (left nil)
                                               (top nil)
                                               (width 300)
                                               (height 200)
                                               (maximize nil)
                                               (has-pinner nil)
                                               (keep-on-top nil)
                                               (window-param nil)
                                               (hidden nil)
                                               (client-movement nil)
                                               (border-class *default-border-class*)
                                               (title-class *default-title-class*)
                                               (html-id nil))
  (let ((app (connection-data-item obj "clog-gui")))
    (unless html-id
      (setf html-id (generate-id)))
    (when (eql (hash-table-count (windows app)) 0)
      ;; If previously no open windows reset default position
      (setf (last-x app) 0)
      (setf (last-y app) 0))
    (unless left
      ;; Generate sensible initial x location
      (setf left (last-x app))
      (incf (last-x app) 10))
    (unless top
      ;; Generate sensible initial y location
      (when (eql (last-y app) 0)
        (setf (last-y app) (menu-bar-height obj)))
      (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 obj))))
    (let ((win (create-child (body app)
                            (format nil
            "<div style='position:fixed;top:~Apx;left:~Apx;width:~Apx;height:~Apx;
                  z-index:~A;visibility:hidden'
                  class='~A'>
                  <div id='~A-title-bar' class='w3-container ~A'
                       style='position:absolute;top:0;right:0;left:0;height:25px'>
                    <span data-drag-obj='~A' data-drag-type='m' id='~A-title'
                      style='position:absolute;top:0;right:20px;left:5px;
                             user-select:none;cursor:move;'>~A</span>~A
                    <span id='~A-closer'
                      style='position:absolute;top:0;right:5px;cursor:pointer;user-select:none;'>&times;</span>
                  </div>
                  <div id='~A-body' style='position:absolute;top:25px;left:0;right:0;bottom:3px;overflow:auto'>~A</div>
                  <div id='~A-sizer' style='position:absolute;right:0;bottom:0;left:0;user-select:none;height:3px;
                       cursor:se-resize;opacity:0'
                       class='w3-right' data-drag-obj='~A' data-drag-type='s'>+</div>
             </div>"
            top left width height (incf (last-z app))   ; outer div
            border-class
            html-id title-class html-id html-id         ; title bar
            title                                       ; title
            (if has-pinner                              ; pinner
              (format nil "<span id='~A-pinner'
                 style='position:absolute;top:0;right:20px;
                        cursor:pointer;user-select:none;'>
                 ☐</span><span>&nbsp;&nbsp;&nbsp;</span>" html-id)
              "")
            html-id                                     ; closer
            html-id content                             ; body
            html-id html-id)                            ; size
                            :clog-type 'clog-gui-window
                            :html-id html-id)))
      (setf (win-title win)
            (attach-as-child win (format nil "~A-title" html-id)))
      (setf (win-param win) window-param)
      (setf (title-bar win)
            (attach-as-child win (format nil "~A-title-bar" html-id)))
      (when has-pinner
        (setf (pinner win) (attach-as-child win (format nil "~A-pinner" html-id))))
      (setf (closer win) (attach-as-child win (format nil "~A-closer" html-id)))
      (setf (sizer win) (attach-as-child win (format nil "~A-sizer" html-id)))
      (setf (content win) (attach-as-child win (format nil "~A-body"  html-id)))
      (setf (gethash (format nil "~A" html-id) (windows app)) win)
      (set-on-click win (lambda (obj)
                          (declare (ignore obj))
                          (unless (> (modal-count app) 0)
                            (window-focus win))))
      (if maximize
          (window-maximize win)
          (fire-on-window-change win app))
      (unless hidden
        (setf (visiblep win) t))
      (when (window-select app)
        (setf (window-select-item win) (create-option (window-select app)
                                                      :content title
                                                      :selected t
                                                      :value html-id)))
      (set-on-double-click (win-title win) (lambda (obj)
                                             (declare (ignore obj))
                                             (window-toggle-maximize win)))
      (if has-pinner
          (set-on-click (pinner win) (lambda (obj)
                                       (declare (ignore obj))
                                       (window-toggle-pinned win :keep-on-top keep-on-top)))
          (when keep-on-top
            (window-keep-on-top win)))
      (set-on-click (closer win) (lambda (obj)
                                   (declare (ignore obj))
                                   (when (fire-on-window-can-close win)
                                     (window-close win))))
      (cond (client-movement
             (clog::jquery-execute win
                             (format nil "draggable({handle:'#~A-title-bar'})" html-id))
             (clog::jquery-execute win "resizable({handles:'se'})")
	     (set-on-touch-start (win-title win) (lambda (obj data) (declare (ignore obj data)) nil) :cancel-event t)
             (set-on-pointer-down (win-title win)
                                  (lambda (obj data)
                                    (declare (ignore obj data))
				    (unless (keep-on-top win)
                                      (setf (z-index win) (incf (last-z app)))
                                      (fire-on-window-change win app)))
				  :capture-pointer t)
             (clog::set-on-event win "dragstart"
                                 (lambda (obj)
                                   (declare (ignore obj))
                                   (fire-on-window-move win)))
             (clog::set-on-event win "dragstop"
                                 (lambda (obj)
                                   (declare (ignore obj))
                                   (fire-on-window-move-done win)))
             (clog::set-on-event win "resizestart"
                                 (lambda (obj)
                                   (declare (ignore obj))
                                   (fire-on-window-size win)))
             (clog::set-on-event win "resizestop"
                                 (lambda (obj)
                                   (declare (ignore obj))
                                   (fire-on-window-size-done win))))
            (t
	     (set-on-touch-start (win-title win) (lambda (obj data) (declare (ignore obj data)) nil) :cancel-event t)
             (set-on-pointer-down
              (win-title win) 'on-gui-drag-down :capture-pointer t)
	     (set-on-touch-start (sizer win) (lambda (obj data) (declare (ignore obj data)) nil) :cancel-event t)
             (set-on-pointer-down
              (sizer win) 'on-gui-drag-down :capture-pointer t)))
      win)))

;;;;;;;;;;;;;;;;;;
;; window-title ;;
;;;;;;;;;;;;;;;;;;

(defgeneric window-title (clog-gui-window)
  (:documentation "Get/setf window title"))

(defmethod window-title ((obj clog-gui-window))
  (inner-html (win-title obj)))

(defgeneric (setf window-title) (value clog-gui-window)
  (:documentation "Set window title"))

(defmethod (setf window-title) (value (obj clog-gui-window))
  (when (window-select-item obj)
    (setf (inner-html (window-select-item obj)) value))
  (setf (inner-html (win-title obj)) value))

;;;;;;;;;;;;;;;;;;
;; window-param ;;
;;;;;;;;;;;;;;;;;;

(defgeneric window-param (clog-gui-window)
  (:documentation "Get/setf window param"))

(defmethod window-param ((obj clog-gui-window))
  (win-param obj))

(defgeneric (setf window-param) (value clog-gui-window)
  (:documentation "Set window param"))

(defmethod (setf window-param) (value (obj clog-gui-window))
  (setf (win-param obj) value))

;;;;;;;;;;;;;;;;;;;;
;; window-content ;;
;;;;;;;;;;;;;;;;;;;;

(defgeneric window-content (clog-gui-window)
  (:documentation "Get window content element."))

(defmethod window-content ((obj clog-gui-window))
  (content obj))

;;;;;;;;;;;;;;;;;;
;; window-focus ;;
;;;;;;;;;;;;;;;;;;

(defgeneric window-focus (clog-gui-window)
  (:documentation "Set CLOG-GUI-WINDOW as focused window."))

(defmethod window-focus ((obj clog-gui-window))
  (let ((app (connection-data-item obj "clog-gui")))
    (unless (keep-on-top obj)
      (when (last-z app)
        (setf (z-index obj) (incf (last-z app)))))
    (when (window-select app)
      (setf (selectedp (window-select-item obj)) t))
    (fire-on-window-change obj app))
  obj)

;;;;;;;;;;;;;;;;;;
;; window-close ;;
;;;;;;;;;;;;;;;;;;

(defgeneric window-close (clog-gui-window)
  (:documentation "Close CLOG-GUI-WINDOW. on-window-can-close is not called.
CLOG-GUI-WINDOW is removed from DOM but still present in the CLOG cache on
the browser."))

(defmethod window-close ((obj clog-gui-window))
  (let ((app (connection-data-item obj "clog-gui")))
    (when app
      (remhash (format nil "~A" (html-id obj)) (windows app))
      (when (window-select app)
        (destroy (window-select-item obj)))
      (remove-from-dom obj)
      (fire-on-window-change nil app)
      (fire-on-window-close obj)))
  nil)

;;;;;;;;;;;;;;;;;;;;;;;;
;; window-maximized-p ;;
;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric window-maximized-p (clog-gui-window)
  (:documentation "Set CLOG-GUI-WINDOW as maximized window."))

(defmethod window-maximized-p ((obj clog-gui-window))
  (last-width obj))

;;;;;;;;;;;;;;;;;;;;;
;; window-maximize ;;
;;;;;;;;;;;;;;;;;;;;;

(defgeneric window-maximize (clog-gui-window &key focus)
  (:documentation "Set CLOG-GUI-WINDOW as maximized window and
:focus (default t)."))

(defmethod window-maximize ((obj clog-gui-window) &key (focus t))
  (bordeaux-threads:with-lock-held ((window-size-mutex obj)) ; prevent race condition of maximize/normalize
    (let ((app (connection-data-item obj "clog-gui")))
      (when focus
	(unless (keep-on-top obj)
	  (window-focus obj)))
      (when (fire-on-window-can-maximize obj)
	(unless (window-maximized-p obj)
          (setf (last-x obj) (left obj))
          (setf (last-y obj) (top obj))
          (setf (last-height obj) (height obj))
          (setf (last-width obj) (width obj)))
	(setf (top obj) (unit :px (menu-bar-height obj)))
	(setf (left obj) (unit :px 0))
	(setf (width obj) (unit :vw 100))
	(setf (left obj) (unit :px (body-left-offset app)))
	(setf (width obj) (- (width obj)
                             (body-left-offset app)
                             (body-right-offset app)))
	(setf (height obj)
              (- (inner-height (window (body app))) (menu-bar-height obj)))
	(fire-on-window-size-done obj)))))

;;;;;;;;;;;;;;;;;;;;;;
;; window-normalize ;;
;;;;;;;;;;;;;;;;;;;;;;

(defgeneric window-normalize (clog-gui-window &key focus)
  (:documentation "Set CLOG-GUI-WINDOW as normalized window an
:focus (default t)."))

(defmethod window-normalize ((obj clog-gui-window) &key (focus t))
  (bordeaux-threads:with-lock-held ((window-size-mutex obj)) ; prevent race condition of maximize/normalize
    (when focus
      (unless (keep-on-top obj)
	(window-focus obj)))
    (when (fire-on-window-can-normalize obj)
      (when (window-maximized-p obj)
	(setf (width obj) (last-width obj))
	(setf (height obj) (last-height obj))
	(setf (top obj) (last-y obj))
	(setf (left obj) (last-x obj))
	(setf (last-width obj) nil)
	(fire-on-window-size-done obj)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; window-toggle-maximize ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric window-toggle-maximize (clog-gui-window)
  (:documentation "Toggle CLOG-GUI-WINDOW as maximize window."))

(defmethod window-toggle-maximize ((obj clog-gui-window))
  (if (window-maximized-p obj)
      (window-normalize obj)
      (window-maximize obj)))

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; window-toggle-pinned ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric window-toggle-pinned (clog-gui-window &key state keep-on-top)
  (:documentation "Toggle the pinned state of a CLOG-GUI-WINDOW. A pinned
window cannot be moved, closed, resized, maximized or normalized. A new
window is always unpinned. If keep-on-top the keep-on-top state is toggled
to match the pinned state. :state forces state. Returns new state"))

(defmethod window-toggle-pinned ((win clog-gui-window) &key (state :toggle)
                                                         keep-on-top)
  (if (or (eq state nil)
          (and (eq state :toggle)
               (pinnedp win)))
      (progn
        (when (pinner win)
          (setf (inner-html (pinner win)) "☐"))
        (when keep-on-top
          (window-keep-on-top win :state nil))
        (setf (pinnedp win) nil)
        (set-on-window-can-close win nil)
        (set-on-window-can-size win nil)
        (set-on-window-can-move win nil)
        (set-on-window-can-maximize win nil)
        (set-on-window-can-normalize win nil)
        nil)
      (flet ((no-op (obj) (declare (ignore obj)) nil))
        (when (pinner win)
          (setf (inner-html (pinner win)) "☑"))
        (when keep-on-top
          (window-keep-on-top win))
        (setf (pinnedp win) t)
        (set-on-window-can-close win #'no-op)
        (set-on-window-can-size win #'no-op)
        (set-on-window-can-move win #'no-op)
        (set-on-window-can-maximize win #'no-op)
        (set-on-window-can-normalize win #'no-op)
        t)))

;;;;;;;;;;;;;;;;;;;;;;;;
;; window-keep-on-top ;;
;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric window-keep-on-top (clog-gui-window &key state)
  (:documentation "Set CLOG-GUI-WINDOW to stay on top based on state (default t)."))

(defmethod window-keep-on-top ((obj clog-gui-window) &key (state t))
  (cond (state
         (setf (keep-on-top obj) t)
         (setf (z-index obj) 1))
        (t
         (setf (keep-on-top obj) nil)
         (window-focus obj))))

;;;;;;;;;;;;;;;;;;;;;;;
;; window-make-modal ;;
;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric window-make-modal (clog-gui-window)
  (:documentation "Set CLOG-GUI-WINDOW to stay on top and prevent all other
interactions. Use window-end-modal to undo."))

(defmethod window-make-modal ((obj clog-gui-window))
  (let ((app (connection-data-item obj "clog-gui")))
    (when (and app
	       (<= (modal-count app) 0))
      (setf (modal-background app) (create-div (body app) :class "w3-overlay"))
      (setf (display (modal-background app)) :block))
    (incf (modal-count app))
    (setf (keep-on-top obj) t)
    (setf (z-index obj) 4)))

;;;;;;;;;;;;;;;;;;;;;;
;; window-end-modal ;;
;;;;;;;;;;;;;;;;;;;;;;

(defgeneric window-end-modal (clog-gui-window)
  (:documentation "Set CLOG-GUI-WINDOW to end modal state."))

(defmethod window-end-modal ((obj clog-gui-window))
  (let ((app (connection-data-item obj "clog-gui")))
    (decf (modal-count app))
    (when (<= (modal-count app) 0)
      (destroy (modal-background app)))
    (window-focus obj)))

;;;;;;;;;;;;;;;;;;;
;; window-center ;;
;;;;;;;;;;;;;;;;;;;

(defgeneric window-center (clog-gui-window)
  (:documentation "Center CLOG-GUI-WINDOW in browser."))

(defmethod window-center ((obj clog-gui-window))
  (let ((body (connection-body obj)))
    (setf (top obj) (unit :px (- (/ (inner-height (window body)) 2.0)
                                 (/ (height obj) 2.0))))
    (setf (left obj) (unit :px (- (/ (inner-width (window body)) 2.0)
                                  (/ (width obj) 2.0))))))

;;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-window-focus ;;
;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric set-on-window-focus (clog-gui-window handler)
  (:documentation "Set the on-window-focus HANDLER"))

(defmethod set-on-window-focus ((obj clog-gui-window) handler)
  (setf (on-window-focus obj) handler))

(defgeneric fire-on-window-focus (clog-gui-window)
  (:documentation "Fire handler if set. (Private)"))

(defmethod fire-on-window-focus ((obj clog-gui-window))
  (when (on-window-focus obj)
    (funcall (on-window-focus obj) obj)))

;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-window-blur ;;
;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric set-on-window-blur (clog-gui-window handler)
  (:documentation "Set the on-window-blur HANDLER"))

(defmethod set-on-window-blur ((obj clog-gui-window) handler)
  (setf (on-window-blur obj) handler))

(defgeneric fire-on-window-blur (clog-gui-window)
  (:documentation "Fire handler if set. (Private)"))

(defmethod fire-on-window-blur ((obj clog-gui-window))
  (when (on-window-blur obj)
    (funcall (on-window-blur obj) obj)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-window-can-close ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric set-on-window-can-close (clog-gui-window handler)
  (:documentation "Set the on-window-can-close HANDLER"))

(defmethod set-on-window-can-close ((obj clog-gui-window) handler)
  (setf (on-window-can-close obj) handler))

(defgeneric fire-on-window-can-close (clog-gui-window)
  (:documentation "Fire handler if set. (Private)"))

(defmethod fire-on-window-can-close ((obj clog-gui-window))
  (if (on-window-can-close obj)
      (funcall (on-window-can-close obj) obj)
      t))

;;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-window-close ;;
;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric set-on-window-close (clog-gui-window handler)
  (:documentation "Set the on-window-close HANDLER"))

(defmethod set-on-window-close ((obj clog-gui-window) handler)
  (setf (on-window-close obj) handler))

(defgeneric fire-on-window-close (clog-gui-window)
  (:documentation "Fire handler if set. (Private)"))

(defmethod fire-on-window-close ((obj clog-gui-window))
  (when (on-window-close obj)
    (funcall (on-window-close obj) obj)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-window-can-size ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric set-on-window-can-size (clog-gui-window handler)
  (:documentation "Set the on-window-can-size HANDLER"))

(defmethod set-on-window-can-size ((obj clog-gui-window) handler)
  (setf (on-window-can-size obj) handler))

(defgeneric fire-on-window-can-size (clog-gui-window)
  (:documentation "Fire handler if set. (Private)"))

(defmethod fire-on-window-can-size ((obj clog-gui-window))
  (if (on-window-can-size obj)
      (funcall (on-window-can-size obj) obj)
      t))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-window-can-maximize ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric set-on-window-can-maximize (clog-gui-window handler)
  (:documentation "Set the on-window-can-maximize HANDLER"))

(defmethod set-on-window-can-maximize ((obj clog-gui-window) handler)
  (setf (on-window-can-maximize obj) handler))

(defgeneric fire-on-window-can-maximize (clog-gui-window)
  (:documentation "Fire handler if set. (Private)"))

(defmethod fire-on-window-can-maximize ((obj clog-gui-window))
  (if (on-window-can-maximize obj)
      (funcall (on-window-can-maximize obj) obj)
      t))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-window-can-normalize ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric set-on-window-can-normalize (clog-gui-window handler)
  (:documentation "Set the on-window-can-normalize HANDLER"))

(defmethod set-on-window-can-normalize ((obj clog-gui-window) handler)
  (setf (on-window-can-normalize obj) handler))

(defgeneric fire-on-window-can-normalize (clog-gui-window)
  (:documentation "Fire handler if set. (Private)"))

(defmethod fire-on-window-can-normalize ((obj clog-gui-window))
  (if (on-window-can-normalize obj)
      (funcall (on-window-can-normalize obj) obj)
      t))

;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-window-size ;;
;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric set-on-window-size (clog-gui-window handler)
  (:documentation "Set the on-window-size HANDLER"))

(defmethod set-on-window-size ((obj clog-gui-window) handler)
  (setf (on-window-size obj) handler))

(defgeneric fire-on-window-size (clog-gui-window)
  (:documentation "Fire handler if set. (Private)"))

(defmethod fire-on-window-size ((obj clog-gui-window))
  (when (on-window-size obj)
    (funcall (on-window-size obj) obj)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-window-size-done ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric set-on-window-size-done (clog-gui-window handler)
  (:documentation "Set the on-window-size-done HANDLER"))

(defmethod set-on-window-size-done ((obj clog-gui-window) handler)
  (setf (on-window-size-done obj) handler))

(defmethod fire-on-window-size-done ((obj clog-gui-window))
  (when (on-window-size-done obj)
    (funcall (on-window-size-done obj) obj)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-window-can-move ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric set-on-window-can-move (clog-gui-window handler)
  (:documentation "Set the on-window-can-move HANDLER"))

(defmethod set-on-window-can-move ((obj clog-gui-window) handler)
  (setf (on-window-can-move obj) handler))

(defgeneric fire-on-window-can-move (clog-gui-window)
  (:documentation "Fire handler if set. (Private)"))

(defmethod fire-on-window-can-move ((obj clog-gui-window))
  (if (on-window-can-move obj)
      (funcall (on-window-can-move obj) obj)
      t))

;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-window-move ;;
;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric set-on-window-move (clog-gui-window handler)
  (:documentation "Set the on-window-move HANDLER"))

(defmethod set-on-window-move ((obj clog-gui-window) handler)
  (setf (on-window-move obj) handler))

(defgeneric fire-on-window-move (clog-gui-window)
  (:documentation "Fire handler if set. (Private)"))

(defmethod fire-on-window-move ((obj clog-gui-window))
  (when (on-window-move obj)
    (funcall (on-window-move obj) obj)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-window-move-done ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric set-on-window-move-done (clog-gui-window handler)
  (:documentation "Set the on-window-move-done HANDLER."))

(defmethod set-on-window-move-done ((obj clog-gui-window) handler)
  (setf (on-window-move-done obj) handler))

(defmethod fire-on-window-move-done ((obj clog-gui-window))
  (when (on-window-move-done obj)
    (funcall (on-window-move-done obj) obj)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - Dialog Boxes
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;
;; alert-toast ;;
;;;;;;;;;;;;;;;;;

(defun alert-toast (obj title content &key
                                        (color-class "w3-red")
                                        (time-out nil)
                                        (place-top nil)
                                        (html-id nil))
  "Create an alert toast with option :TIME-OUT. If place-top is t then alert
is placed in DOM at top of html body instead of bottom of html body."
  (unless html-id
      (setf html-id (generate-id)))
  (let* ((body   (connection-body obj))
         (win    (create-child body
                             (format nil
"  <div class='w3-panel ~A w3-animate-right w3-display-container'>~
   <span id=~A-close class='w3-button w3-large w3-display-topright'>&times;</span>~
   <h3>~A</h3>~
   <p>~A</p>~
</div>"
                              color-class
                              html-id
                              title
                              content)
                             :html-id html-id
                             :auto-place nil)))
    (if place-top
        (place-inside-top-of body win)
        (place-inside-bottom-of body win))
    (set-on-click
     (attach-as-child obj (format nil "~A-close" html-id))
     (lambda (obj)
       (declare (ignore obj))
       (destroy win)))
    (when time-out
      (sleep time-out)
      (destroy win))))

;;;;;;;;;;;;;;;;;;
;; alert-dialog ;;
;;;;;;;;;;;;;;;;;;

(defun alert-dialog (obj content &key (modal t)
                                   (title "About")
                                   (left nil) (top nil)
                                   (width 300) (height 200)
                                   (client-movement nil)
                                   (html-id nil))
  "Create an alert dialog box with CONTENT centered."
  (unless html-id
      (setf html-id (generate-id)))
  (let* ((body (connection-body obj))
         (win  (create-gui-window obj
                                  :title    title
                                  :content  (format nil
"<div class='w3-panel'>
<center>~A<br><br>
<button class='w3-button w3-black' id='~A-btn'>OK</button>
</center>
</div>" content html-id)
                                  :top             top
                                  :left            left
                                  :width           width
                                  :height          height
                                  :hidden          t
                                  :client-movement client-movement
                                  :html-id         html-id))
         (btn  (attach-as-child win (format nil "~A-btn" html-id))))
    (unless top
      (setf (top win) (unit :px (- (/ (inner-height (window body)) 2.0)
                                   (/ (height win) 2.0)))))
    (unless left
      (setf (left win) (unit :px (- (/ (inner-width (window body)) 2.0)
                                    (/ (width win) 2.0)))))
    (setf (visiblep win) t)
    (when modal
      (window-make-modal win))
    (focus btn)
    (set-on-click btn (lambda (obj)
                        (declare (ignore obj))
                        (window-end-modal win)
                        (window-close win)))
    (set-on-window-close win (lambda (obj)
                               (declare (ignore obj))
                               (when modal
                                 (window-end-modal win))))))

;;;;;;;;;;;;;;;;;;
;; input-dialog ;;
;;;;;;;;;;;;;;;;;;

(defun input-dialog (obj content on-input &key (modal t)
                                            (title "Input")
                                            (size 20)
                                            (rows 1)
                                            (default-value "")
                                            (left nil) (top nil)
                                            (width 300) (height 200)
                                            (client-movement nil)
                                            (html-id nil))
  "Create an input dialog box with CONTENT centered and an input box.
Calls on-input with input box contents or nil if canceled."
  (unless html-id
      (setf html-id (generate-id)))
  (let* ((body (connection-body obj))
         (inp  (if (eql rows 1)
                   (format nil "<input type='text' id='~A-input' size='~A' value='~A'>"
                           html-id
                           size
                           (escape-string default-value :html t))
                   (format nil "<textarea id='~A-input' cols='~A' rows='~A'>~A</textarea>"
                           html-id
                           size
                           rows
                           (escape-string default-value :html t))))
         (win  (create-gui-window obj
                                  :title          title
                                  :content        (format nil
"<div class='w3-panel'>
<center>~A<br><br>
<form class='w3-container' onSubmit='return false;'>
~A<br><br>
<button class='w3-button w3-black' style='width:7em' id='~A-ok'>OK</button>
<button class='w3-button w3-black' style='width:7em' id='~A-cancel'>Cancel</button>
</form>
</center>
</div>"
      content
      inp
      html-id  ; ok
      html-id) ; cancel
                                  :top             top
                                  :left            left
                                  :width           width
                                  :height          height
                                  :hidden          t
                                  :client-movement client-movement
                                  :html-id         html-id))
         (input  (attach-as-child win (format nil "~A-input" html-id)
                                  :clog-type 'clog:clog-form-element))
         (ok     (attach-as-child win (format nil "~A-ok" html-id)))
         (cancel (attach-as-child win (format nil "~A-cancel" html-id))))
    (unless top
      (setf (top win) (unit :px (- (/ (inner-height (window body)) 2.0)
                                   (/ (height win) 2.0)))))
    (unless left
      (setf (left win) (unit :px (- (/ (inner-width (window body)) 2.0)
                                    (/ (width win) 2.0)))))
    (setf (visiblep win) t)
    (when modal
      (window-make-modal win))
    (focus input)
    (set-on-click cancel (lambda (obj)
                           (declare (ignore obj))
                           (window-close win))
                  :one-time t)
    (set-on-click ok (lambda (obj)
                       (declare (ignore obj))
                       (set-on-window-close win nil)
                       (when modal
                         (window-end-modal win))
                       (window-close win)
                       (funcall on-input (value input)))
                  :one-time t)
    (set-on-window-close win (lambda (obj)
                               (declare (ignore obj))
                               (when modal
                                 (window-end-modal win))
                               (funcall on-input nil)))))

;;;;;;;;;;;;;;;;;;;;
;; confirm-dialog ;;
;;;;;;;;;;;;;;;;;;;;

(defun confirm-dialog (obj content on-input &key (modal t)
                                              (title "Confirm")
                                              (ok-text "OK")
                                              (cancel-text "Cancel")
                                              (left nil) (top nil)
                                              (width 300) (height 200)
                                              (client-movement nil)
                                              (html-id nil))
  "Create a confirmation dialog box with CONTENT centered.
Calls on-input with t if confirmed or nil if canceled."
  (unless html-id
      (setf html-id (generate-id)))
  (let* ((body (connection-body obj))
         (win  (create-gui-window obj
                                  :title          title
                                  :content        (format nil
"<div class='w3-panel'>
<center>~A<br><br>
<form class='w3-container' onSubmit='return false;'>
<button class='w3-button w3-black' style='width:7em' id='~A-ok'>~A</button>
<button class='w3-button w3-black' style='width:7em' id='~A-cancel'>~A</button>
</form>
</center>
</div>" content
        html-id ok-text      ; ok
        html-id cancel-text) ; cancel
                                  :top             top
                                  :left            left
                                  :width           width
                                  :height          height
                                  :hidden          t
                                  :client-movement client-movement
                                  :html-id         html-id))
         (ok     (attach-as-child win (format nil "~A-ok" html-id)))
         (cancel (attach-as-child win (format nil "~A-cancel" html-id))))
    (unless top
      (setf (top win) (unit :px (- (/ (inner-height (window body)) 2.0)
                                   (/ (height win) 2.0)))))
    (unless left
      (setf (left win) (unit :px (- (/ (inner-width (window body)) 2.0)
                                    (/ (width win) 2.0)))))
    (setf (visiblep win) t)
    (when modal
      (window-make-modal win))
    (focus ok)
    (set-on-click cancel (lambda (obj)
                           (declare (ignore obj))
                           (when modal
                                 (window-end-modal win))
                           (window-close win)
                           (funcall on-input nil))
                  :one-time t)
    (set-on-click ok (lambda (obj)
                       (declare (ignore obj))
                       (set-on-window-close win nil)
                       (when modal
                         (window-end-modal win))
                       (window-close win)
                       (funcall on-input t))
                  :one-time t)
    (set-on-window-close win (lambda (obj)
                               (declare (ignore obj))
                               (when modal
                                 (window-end-modal win))
                               (funcall on-input nil)))))

;;;;;;;;;;;;;;;;;
;; form-dialog ;;
;;;;;;;;;;;;;;;;;

(defun form-dialog (obj content fields on-input &key (modal t)
                                                  (title "Form")
                                                  (ok-text "OK")
                                                  (cancel-text "Cancel")
                                                  (left nil) (top nil)
                                                  (width 400) (height 500)
                                                  (size 40) (rows 4)
                                                  (client-movement nil)
                                                  (html-id nil))
  "Create a form dialog box with CONTENT followed by FIELDS.
FIELDS is a list of lists each list has:

    (1) Field name         - Used for (name attribute)
    (2) Field description  - Used for label
    (3) Field type         - Optional (defaults to :text)
    (4) Field type options - Optional

Special field types

   Field Type     Field Type Options
   =============  ==================
   :filename      default dir -- NOTE: This is _server_ side!
   :checkbox      t if checked
   :radiobox      a-list ((label name)) a third value can be added \"checked\"
   :select        a-list ((label name)) a third value can be added \"selected\"
   :textarea      value
   :text          value
     (any text input types also work :email, :tel, etc.
      see FORM-ELEMENT-TYPE)

The size of any texarea field is controled by the size and rows parameters

Calls on-input after OK or Cancel with an a-list of field name to value
if confirmed or nil if canceled."
  (unless html-id
    (setf html-id (generate-id)))
  (let* ((body (connection-body obj))
         (fls (format nil "~{~A~}"
                      (mapcar (lambda (l)
                                (cond
                                  ((eq (third l) :select)
                                   (format nil
                                           "<div><label class='w3-text-black'><b>~A</b></label>~
                               <select class='w3-select w3-border' name='~A-~A'>~A</select></div>"
                                           (first l) html-id (second l)
                                           (format nil "~{~A~}"
                                                   (mapcar (lambda (s)
                                                             (format nil
                                                                     "<option value='~A' ~A>~A</option>"
                                                                     (second s)
                                                                     (if (third s)
                                                                         (third s)
                                                                         "")
                                                                     (first s)))
                                                           (fourth l)))))
                                  ((eq (third l) :radio)
                                   (format nil
                                           "<div><label class='w3-text-black'><b>~A</b></label>~A</div>"
                                           (first l)
                                           (format nil "~{~A~}"
                                                   (mapcar (lambda (s)
                                                             (format nil
                                                                     "<div><input type=radio class='w3-radio' name='~A-~A'~
                                      id='~A-~A-~A' value='~A' ~A> ~
                                     <label for='~A-~A-~A'>~A</label></div>"
                                                                     html-id (second l)
                                                                     html-id (second l) (second s)
                                                                     (second s)
                                                                     (if (third s)
                                                                         (third s)
                                                                         "")
                                                                     html-id (second l) (second s)
                                                                     (first s)))
                                                           (fourth l)))))
                                  ((eq (third l) :checkbox)
                                   (format nil
                                           "<div><input class='w3-check' type='checkbox' ~
                                                  name='~A-~A' id='~A-~A' ~A> ~
                                                  <label class='w3-text-black' for='~A-~A'>~
                                                  <b>~A</b></label>~
                                            </div>"
                                           html-id (second l) html-id (second l)
                                           (if (fourth l)
                                               "checked"
                                               "")
                                           html-id (second l)
                                           (first l)))
                                  ((eq (third l) :textarea)
                                   (format nil
                                           "<div><label class='w3-text-black'><b>~A</b></label>
                                                 <textarea
                                                  name='~A-~A' id='~A-~A' cols='~A' rows='~A'>~A</textarea></div>"
                                           (first l)
                                           html-id
                                           (second l)
                                           html-id
                                           (second l)
                                           size
                                           rows
                                           (if (fourth l)
                                               (fourth l)
                                               "")))
                                  ((third l)
                                   (format nil
                                           "<div><label class='w3-text-black'><b>~A</b></label>~
                                                 <input class='w3-input w3-border' type='~A'~
                                                  name='~A-~A' id='~A-~A' value='~A'></div>"
                                           (first l) (third l)
                                           html-id (second l) html-id (second l)
                                           (if (fourth l)
                                               (fourth l)
                                               "")))
                                  (t
                                   (format nil
                                           "<div><label class='w3-text-black'><b>~A</b></label>~
                               <input class='w3-input w3-border' type='text' name='~A-~A' id='~A-~A'></div>"
                                           (first l) html-id (second l) html-id (second l)))))
                              fields)))
         (win  (create-gui-window obj
                                  :title          title
                                  :content        (format nil
                                                          "<div class='w3-panel'>
~A
<form class='w3-container' onSubmit='return false;'>
~A
<br><center>
<button class='w3-button w3-black' style='width:7em' id='~A-ok'>~A</button>
<button class='w3-button w3-black' style='width:7em' id='~A-cancel'>~A</button>
</center>
</form>
</div>" (if content
            (format nil "<center>~A</center><br>" content)
            "")
                                                          fls
                                                          html-id ok-text ; ok
                                                          html-id cancel-text) ; cancel
                                  :top             top
                                  :left            left
                                  :width           width
                                  :height          height
                                  :hidden          t
                                  :client-movement client-movement
                                  :html-id         html-id))
         (ok     (attach-as-child win (format nil "~A-ok" html-id)))
         (cancel (attach-as-child win (format nil "~A-cancel" html-id))))
    (unless top
      (setf (top win) (unit :px (- (/ (inner-height (window body)) 2.0)
                                   (/ (height win) 2.0)))))
    (unless left
      (setf (left win) (unit :px (- (/ (inner-width (window body)) 2.0)
                                    (/ (width win) 2.0)))))
    (setf (visiblep win) t)
    (when modal
      (window-make-modal win))
    (mapcar (lambda (l)
              (when (eq (third l) :filename)
                (let ((fld (attach-as-child body (format nil "~A-~A"
                                                         html-id
                                                         (second l))
                                            :clog-type 'clog:clog-form-element)))
                  (set-on-click fld (lambda (obj)
                                      (declare (ignore obj))
                                      (server-file-dialog body (first l) (fourth l)
                                                          (lambda (fname)
                                                            (setf (value fld) fname))))))))
            fields)
    (js-execute obj (format nil "$('[name=~A-~A]').focus()"
                            html-id
                            (cadar fields)))
    (set-on-click cancel (lambda (obj)
                           (declare (ignore obj))
                           (window-close win))
                  :one-time t)
    (set-on-click ok (lambda (obj)
                       (declare (ignore obj))
                       (set-on-window-close win nil)
                       (when modal
                         (window-end-modal win))
                       (let ((result (mapcar
                                      (lambda (l)
                                        `(,(second l)
                                          ,(let ((name (format nil "~A-~A" html-id (second l))))
                                             (cond ((eq (third l) :select)
                                                    (select-value win name))
                                                   ((eq (third l) :radio)
                                                    (radio-value win name))
                                                   ((eq (third l) :checkbox)
                                                    (checkbox-value win name))
                                                   ((eq (third l) :textarea)
                                                    (textarea-value win name))
                                                   (t
                                                    (name-value win name))))))
                                      fields)))
                         (window-close win)
                         (funcall on-input result)))
                  :one-time t)
    (set-on-window-close win (lambda (obj)
                               (declare (ignore obj))
                               (when modal
                                 (window-end-modal win))
                               (funcall on-input nil)))))

;;;;;;;;;;;;;;;;;;;;;;;;
;; server-file-dialog ;;
;;;;;;;;;;;;;;;;;;;;;;;;

(defun server-file-dialog (obj title initial-dir on-file-name
                           &key (modal t)
                             (left nil) (top nil) (width 390) (height 425)
                             (maximize nil)
                             (initial-filename nil)
                             (client-movement nil)
                             (html-id nil))
  "Create a local file dialog box called TITLE using INITIAL-DIR on server
machine, upon close ON-FILE-NAME called with filename or nil if failure."
  (let* ((body (connection-body obj))
         (win  (create-gui-window obj
                                  :title           title
                                  :maximize        maximize
                                  :top             top
                                  :left            left
                                  :width           width
                                  :height          height
                                  :hidden          t
                                  :client-movement client-movement
                                  :html-id         html-id))
         (box    (create-div (window-content win) :class "w3-panel"))
         (form   (create-form box))
         (fname  (file-namestring initial-dir))
         (dirs   (create-select form))
         (files  (create-select form))
         (input  (create-form-element form :input :label
                                     (create-label form :content "File Name:")))
         (ok     (create-button form :content "OK"
                                     :class "w3-button w3-black w3-margin"))
         (cancel (create-button form :content "Cancel"
                                     :class "w3-button w3-black w3-margin")))
    (unless top
      (setf (top win) (unit :px (- (/ (inner-height (window body)) 2.0)
                                   (/ (height win) 2.0)))))
    (unless left
      (setf (left win) (unit :px (- (/ (inner-width (window body)) 2.0)
                                    (/ (width win) 2.0)))))
    (setf (size dirs) 5)
    (setf (box-width dirs) "100%")
    (setf (size files) 7)
    (setf (box-width files) "100%")
    (setf (box-width input) "100%")
    (setf (overflow files) :auto)
    (setf (overflow dirs) :auto)
    (setf (width ok) "7em")
    (setf (width cancel) "7em")
    (setf (visiblep win) t)
    (when modal
      (window-make-modal win))
    (flet ((populate-dirs (d)
             (let ((dir (directory-namestring d)))
               (setf (inner-html dirs) "")
               (add-select-option dirs (format nil "~A" dir) ".")
               (setf (value input) (if (equal fname "")
                                       (truename dir)
                                       (format nil "~A~A" (truename dir) fname)))
               (unless (or (equalp dir "/") (equalp dir #P"/"))
                 (add-select-option dirs (format nil "~A../" dir) ".."))
               (dolist (item (uiop:subdirectories dir))
                 (add-select-option dirs item item))))
           (populate-files (dir)
             (setf (inner-html files) "")
             (dolist (item (uiop:directory-files (directory-namestring dir)))
               (add-select-option files item (file-namestring item))))
           (caret-at-end ()
             (focus input)
             (js-execute win (format nil "~A.setSelectionRange(~A.value.length,~A.value.length)"
                                     (clog::script-id input)
                                     (clog::script-id input)
                                     (clog::script-id input)))))
      (populate-dirs initial-dir)
      (populate-files initial-dir)
      (when initial-filename
        (ignore-errors
         (setf (value input) (truename initial-filename)))
        (caret-at-end))
      (set-on-change files (lambda (obj)
                             (declare (ignore obj))
                             (setf (value input) (truename (value files)))
                             (caret-at-end)))
      (set-on-change dirs (lambda (obj)
                            (declare (ignore obj))
                            (setf (value input) (value dirs))
                            (caret-at-end)
                            (populate-files (value dirs))))
      (set-on-double-click dirs
                           (lambda (obj)
                             (declare (ignore obj))
                             (populate-dirs (truename (value dirs)))))
      (set-on-double-click files (lambda (obj)
                                   (declare (ignore obj))
                                   (click ok))))
    (set-on-window-close win (lambda (obj)
                               (declare (ignore obj))
                               (when modal
                                 (window-end-modal win))
                               (funcall on-file-name nil)))
    (set-on-click cancel (lambda (obj)
                           (declare (ignore obj))
                           (window-close win))
                  :one-time t)
    (set-on-click ok (lambda (obj)
                       (declare (ignore obj))
                       (set-on-window-close win nil)
                       (when modal
                         (window-end-modal win))
                       (window-close win)
                       (funcall on-file-name (value input)))
                  :one-time t)))


;;;;;;;;;;;;;;;;;;;;;;
;; dialog-in-stream ;;
;;;;;;;;;;;;;;;;;;;;;;

(defclass dialog-in-stream (trivial-gray-streams:fundamental-character-input-stream)
  ((clog-obj :reader   obj       :initarg  :clog-obj)
   (outbuf   :reader   outbuf    :initarg  :source)
   (buffer   :accessor buffer-of :initform "")
   (index    :accessor index     :initform 0))
  (:documentation "dialog-in-stream and dialog-out-stream can be combined with
make-two-way-stream to provide a *query-io* using a clog-gui instead of console)"))

(defmethod trivial-gray-streams:stream-read-char ((stream dialog-in-stream))
  (when (eql (index stream) (length (buffer-of stream)))
    (setf (buffer-of stream) "")
    (setf (index stream) 0))
  (when (eql (index stream) 0)
    (let ((sem (bordeaux-threads:make-semaphore)))
      (input-dialog (obj stream) (prompt (outbuf stream)) (lambda (result)
                                                            (add-line stream result)
                                                            (bordeaux-threads:signal-semaphore sem))
                    :modal nil)
      (bordeaux-threads:wait-on-semaphore sem)))
  (when (< (index stream) (length (buffer-of stream)))
    (prog1
        (char (buffer-of stream) (index stream))
      (incf (index stream)))))

(defmethod trivial-gray-streams:stream-unread-char ((stream dialog-in-stream) character)
  (decf (index stream)))

(defmethod trivial-gray-streams:stream-line-column ((stream dialog-in-stream))
  nil)

(defmethod add-line ((stream dialog-in-stream) text)
  (setf (buffer-of stream) (format nil "~A~A~%" (buffer-of stream) text)))

;;;;;;;;;;;;;;;;;;;;;;;
;; dialog-out-stream ;;
;;;;;;;;;;;;;;;;;;;;;;;

(defclass dialog-out-stream (trivial-gray-streams:fundamental-character-output-stream)
  ((buffer :accessor buffer-of :initform ""))
  (:documentation "dialog-in-stream and dialog-out-stream can be combined with
make-two-way-stream to provide a *query-io* using a clog-gui instead of console)"))

(defmethod trivial-gray-streams:stream-write-char ((stream dialog-out-stream) character)
  (setf (buffer-of stream) (format nil "~A~A" (buffer-of stream) character)))

(defmethod trivial-gray-streams:stream-line-column ((stream dialog-out-stream))
  nil)

(defmethod prompt ((stream dialog-out-stream))
  (prog1
      (buffer-of stream)
    (setf (buffer-of stream) "")))

;;;;;;;;;;;;
;; one-of ;;
;;;;;;;;;;;;

(defun one-of-dialog (obj intro choices &key (title "Please choose one") (prompt "Choice"))
  "Prompt a dialog box with TITLE and INTRO using list of CHOICES and PROMPT"
  (let ((q  (format nil "<pre>~A</pre><p style='text-align:left'>" intro))
        (n (length choices)) (i))
    (do ((c choices (cdr c)) (i 1 (+ i 1)))
        ((null c))
      (setf q (format nil "~A~&[~D] ~A~%<br>" q i (car c))))
    (do () ((typep i `(integer 1 ,n)))
      (setf q (format nil "~A~&~A:" q prompt))
      (let ((sem (bordeaux-threads:make-semaphore))
            r)
        (input-dialog obj q (lambda (result)
                              (setf r (or result ""))
                              (bordeaux-threads:signal-semaphore sem))
                      :title title
                      :modal nil
                      :width 640
                      :height 480)
        (bordeaux-threads:wait-on-semaphore sem)
        (setq i (read-from-string r))))
    (nth (- i 1) choices)))

(defparameter *default-icon*
  "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAACAAAAAcCAYAAAAAwr0iAAAAAXNSR0IArs4c6QAAAKZlWElmTU0A
KgAAAAgABwEGAAMAAAABAAIAAAESAAMAAAABAAEAAAEaAAUAAAABAAAAYgEbAAUAAAABAAAAagEo
AAMAAAABAAIAAAExAAIAAAAVAAAAcodpAAQAAAABAAAAiAAAAAAAAABIAAAAAQAAAEgAAAABUGl4
ZWxtYXRvciBQcm8gMi4wLjUAAAACoAIABAAAAAEAAAAgoAMABAAAAAEAAAAcAAAAAMSXmL0AAAAJ
cEhZcwAACxMAAAsTAQCanBgAAAQRaVRYdFhNTDpjb20uYWRvYmUueG1wAAAAAAA8eDp4bXBtZXRh
IHhtbG5zOng9ImFkb2JlOm5zOm1ldGEvIiB4OnhtcHRrPSJYTVAgQ29yZSA2LjAuMCI+CiAgIDxy
ZGY6UkRGIHhtbG5zOnJkZj0iaHR0cDovL3d3dy53My5vcmcvMTk5OS8wMi8yMi1yZGYtc3ludGF4
LW5zIyI+CiAgICAgIDxyZGY6RGVzY3JpcHRpb24gcmRmOmFib3V0PSIiCiAgICAgICAgICAgIHht
bG5zOmV4aWY9Imh0dHA6Ly9ucy5hZG9iZS5jb20vZXhpZi8xLjAvIgogICAgICAgICAgICB4bWxu
czp4bXA9Imh0dHA6Ly9ucy5hZG9iZS5jb20veGFwLzEuMC8iCiAgICAgICAgICAgIHhtbG5zOnRp
ZmY9Imh0dHA6Ly9ucy5hZG9iZS5jb20vdGlmZi8xLjAvIj4KICAgICAgICAgPGV4aWY6Q29sb3JT
cGFjZT4xPC9leGlmOkNvbG9yU3BhY2U+CiAgICAgICAgIDxleGlmOlBpeGVsWERpbWVuc2lvbj4z
MjwvZXhpZjpQaXhlbFhEaW1lbnNpb24+CiAgICAgICAgIDxleGlmOlBpeGVsWURpbWVuc2lvbj4y
ODwvZXhpZjpQaXhlbFlEaW1lbnNpb24+CiAgICAgICAgIDx4bXA6Q3JlYXRvclRvb2w+UGl4ZWxt
YXRvciBQcm8gMi4wLjU8L3htcDpDcmVhdG9yVG9vbD4KICAgICAgICAgPHhtcDpNZXRhZGF0YURh
dGU+MjAyMS0wMi0wNFQwMzo0MDoxOVo8L3htcDpNZXRhZGF0YURhdGU+CiAgICAgICAgIDx0aWZm
OlJlc29sdXRpb25Vbml0PjI8L3RpZmY6UmVzb2x1dGlvblVuaXQ+CiAgICAgICAgIDx0aWZmOlBo
b3RvbWV0cmljSW50ZXJwcmV0YXRpb24+MjwvdGlmZjpQaG90b21ldHJpY0ludGVycHJldGF0aW9u
PgogICAgICAgICA8dGlmZjpDb21wcmVzc2lvbj4xPC90aWZmOkNvbXByZXNzaW9uPgogICAgICAg
ICA8dGlmZjpPcmllbnRhdGlvbj4xPC90aWZmOk9yaWVudGF0aW9uPgogICAgICAgICA8dGlmZjpY
UmVzb2x1dGlvbj43MjAwMDAvMTAwMDA8L3RpZmY6WFJlc29sdXRpb24+CiAgICAgICAgIDx0aWZm
OllSZXNvbHV0aW9uPjcyMDAwMC8xMDAwMDwvdGlmZjpZUmVzb2x1dGlvbj4KICAgICAgPC9yZGY6
RGVzY3JpcHRpb24+CiAgIDwvcmRmOlJERj4KPC94OnhtcG1ldGE+CjH2KYwAAAMuSURBVEgN7Za7
a1RBFId3N3GjUQMJNuIDGwVFRW0sFBTRNpWVhYKFWtko2PgH2NgpgtgERK1EUQSxsBIMYpAIgsRX
o4WFYNS8k/X7zc7vOrmbZO+uYOWBb8+ZM3PmzOvObKn0X/7hCtRqtXI+XYMj3+BvyySt0kcFpqEG
y2J5slwuz2G3L3RegW7ozPeCr2shv9tRV4ZK2ytAsGYywyw0qxLlbtQkyD+LXzOWfx1qF2yGLbAc
blP/BB2WRrolodOqEig5sg0q2GOgxBMwjW8TnKTjfuiADzAIK+AudWfQrQuBXY7Cvg6/4BFslx+9
D87CeTgCvW5vje8ODINWq7gQEJKjte+PIZVvFC7DQTgEG9OeKetMhIToAfgEPWmbJW0a6zRrhr3w
HCQzMA5acstFd4SjB1ZHrTOieA1O8gJ0HpoLDZ18DfYrkEyBBiCZg4lg1X9uovryPeM7ACMguQfN
t8CN0H2gfZNMwmyw6smjmQ1I5ddwAnZDP1yDH2C5mh9gQ5mW3vOV2EMxUjN18uiap9LtUMUoaIUs
jj3VkNAOWnbCqqT8NEYredpZdDcoJfH2pJVegS84t7r/TOOsQjgscmLr5D4Aifbcow+OAj8ahFZE
KFYHVnIlS2oDp+7rTCgfgzcgUXCryUNg8vM92h/RG5QIXb9TMMKVjD4KN+AlWLTk7Sb3rL30urT2
x+R/vgCcYfZofRqpqIMie57G2M4fxhEq9sTkHdhh0vlXbFwNkAnQt69G7TxYUzF+Fn0JhmCYN+Id
ifUuzGGHRyw/gPdUSpR03pkI3mI/Tq4Ex0l0y2Fx1lly+3UYvAWHsSW+1Vpd/nTZLygBfek/g57N
QJY0NVTpMrYP4E/sVkSD9cDvJ/2Fa9zlRTXBXoWd2J65Tq1m5TLmgqI2Y7FG+7xWidDFHhuPigAP
Qvf3W7BoALr/jS4lobJnjVkbhPAMo7P/De6/kCbQg9Cnchr0bDaTrzQ4B47NH+5Fc2d7n7ZQR5ze
7B8rZd3be2EHrAe9E/rP9xmewUPaj6LDoUtj5WtLSKpTG2ZUpAO1VUyRtmmbQgGxYw8mXCCxE8c3
fttpliXs3y+7fSKpo8d7AAAAAElFTkSuQmCC")