tinmop/src/windows.lisp

;; tinmop: a multiprotocol client
;; Copyright © cage

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(in-package :windows)

(defclass key-config-holder ()
  ((key-config
    :initform nil
    :initarg :key-config
    :accessor key-config)))

(defclass tree-holder ()
  ((tree-color-map
    :initform ()
    :initarg  :tree-color-map
    :accessor tree-color-map)
   (render-arrow-value
    :initform ">"
    :initarg  :render-arrow-value
    :accessor render-arrow-value)
   (render-leaf-value
    :initform "-"
    :initarg  :render-leaf-value
    :accessor render-leaf-value)
   (render-branch-value
    :initform "+"
    :initarg  :render-branch-value
    :accessor render-branch-value)
   (render-spacer-value
    :initform "-"
    :initarg  :render-spacer-value
    :accessor render-spacer-value)
   (render-vertical-line-value
    :initform "|"
    :initarg  :render-vertical-line-value
    :accessor render-vertical-line-value)))

(defun refresh-config-color-map (window config-win-key)
  (assert window)
  (assert config-win-key)
  (with-accessors ((tree-color-map tree-color-map)) window
    (setf tree-color-map
          (swconf:make-tree-colormap config-win-key))))

(defun refresh-config-tree-rendering-values (window config-win-key)
  (with-accessors ((render-arrow-value         render-arrow-value)
                   (render-leaf-value          render-leaf-value)
                   (render-branch-value        render-branch-value)
                   (render-spacer-value        render-spacer-value)
                   (render-vertical-line-value render-vertical-line-value)) window
    (multiple-value-bind (arrow leaf branch spacer vertical-line)
        (swconf:tree-config-rendering-values config-win-key)
      (setf render-arrow-value         arrow
            render-leaf-value          leaf
            render-branch-value        branch
            render-spacer-value        spacer
            render-vertical-line-value vertical-line))))

(defmethod refresh-config :after ((object tree-holder))
  (with-accessors ((key-config key-config)) object
    (refresh-config-color-map object key-config)
    (refresh-config-tree-rendering-values object key-config)))

(defparameter *window-stack* (make-instance 'stack))

(defclass wrapper-window (m-tree key-config-holder)
  ((croatoan-window
    :initform nil
    :initarg  :croatoan-window
    :accessor croatoan-window
    :documentation "The lowlevel (ncurses) window")
   (keybindings
    :initform nil
    :initarg  :keybindings
    :accessor keybindings
    :documentation "The keymap associated to this window")
   (modal
    :initform nil
    :initarg  :modal
    :reader   modalp
    :writer   (setf modalp)))
  (:documentation "This is the parent of all the windows in this program"))

(defmethod initialize-instance :after ((object wrapper-window) &key &allow-other-keys)
  (stack-push *window-stack* object)
  (win-show object))

(defmethod print-object ((object wrapper-window) stream)
  (print-unreadable-object (object stream :type t :identity t)))

(defmacro with-croatoan-window ((slot window) &body body)
  `(with-accessors ((,slot croatoan-window)) ,window
     ,@body))

(define-constant +min-shown-win-height+ 3 :test #'=)

(define-constant +min-shown-win-width+  3 :test #'=)

(defmacro when-window-shown ((window &key
                                       (min-valid-height +min-shown-win-height+)
                                       (min-valid-width  +min-shown-win-width+))
                             &body body)
  (with-gensyms (height width)
    `(when ,window
       (let ((,height (if (window-uses-border-p ,window)
                          (win-height-no-border ,window)
                          (win-height           ,window)))
             (,width  (if (window-uses-border-p ,window)
                          (win-width-no-border  ,window)
                          (win-width            ,window))))
         (when (and (win-shown-p ,window)
                    (>= ,height ,min-valid-height)
                    (>= ,width  ,min-valid-width))
           ,@body)))))

(defun win-clear (window &key (redraw nil))
  "Clear window content"
  (c:clear (croatoan-window window) :target :window :redraw redraw))

(defmacro gen-simple-win->croatoan-specialized-wrapper (fn-name &optional (prefix nil))
  "Generate micro  wrapper for simple curses  library function (window
height, position and so on)"
  (with-gensyms (window inner)
    `(defun ,(format-fn-symbol t "~@[~a-~]~a" prefix fn-name) (,window)
       (with-croatoan-window (,inner ,window)
         (,(format-fn-symbol 'c "~a" fn-name) ,inner)))))

(gen-simple-win->croatoan-specialized-wrapper width   win)

(gen-simple-win->croatoan-specialized-wrapper height  win)

(gen-simple-win->croatoan-specialized-wrapper box     win)

(gen-simple-win->croatoan-specialized-wrapper bgcolor win)

(gen-simple-win->croatoan-specialized-wrapper fgcolor win)

(gen-simple-win->croatoan-specialized-wrapper refresh win)

(gen-simple-win->croatoan-specialized-wrapper touch  win)

(defun menu-select (window &key (force-show-cursor t))
  (with-croatoan-window (croatoan-window window)
    (when force-show-cursor
      (cursor-show))
    (prog1
        (c:edit croatoan-window)
      (when force-show-cursor
        (cursor-hide))
      (win-close window))))

(defun win-visible-p (win)
  (with-croatoan-window (croatoan-window win)
    (c:visiblep croatoan-window)))

(defun win-close (window)
  (with-croatoan-window (croatoan-window window)
    (stack-remove-element *window-stack* window)
    (close croatoan-window)))

(defun maybe-close-window (win)
  "close `win' if it is a wrapper-window"
  (and win
       (typep win 'wrapper-window)
       (win-close win)))

(defun win-raise-to-top (window)
  (stack-raise-to-top *window-stack* window))

(defun win-width-no-border (win)
  (- (win-width win)
     2))

(defun win-height-no-border (win)
  (- (win-height win)
     2))

(defun win-x (win)
  (with-croatoan-window (inner-window win)
    (second (c:widget-position inner-window))))

(defun win-y (win)
  (with-croatoan-window (inner-window win)
    (first (c:widget-position inner-window))))

(defmacro with-window-width ((win w) &body body)
  `(let ((,w (win-width  ,win)))
     ,@body))

(defmacro with-window-height ((win h) &body body)
  `(let ((,h (win-height  ,win)))
     ,@body))

(defmacro with-window-sizes ((win w h) &body body)
  `(with-window-width (,win ,w)
     (with-window-height (,win ,h)
     ,@body)))

(defun calc-center-on-window-width (win message)
  (with-window-width (win w)
    (let ((win-center     (truncate (/ w 2)))
          (message-center (truncate (/ (length message) 2))))
      (- win-center message-center))))

(defun calc-bottom-of-window-height (win &key (has-border-p nil))
  (with-window-height (win h)
    (if has-border-p
        (- h 2)
        (- h 1))))

(defun win-move-cursor (window x y &key relative)
  "Wrapper of croatoan:move-window"
  (with-croatoan-window (inner window)
    (c:move inner y x :relative relative)))

(defun win-move-cursor-direction (window direction &optional (n 1))
  "Wrapper for croatoan:move-direction"
  (with-croatoan-window (inner window)
    (c:move-direction inner direction n)))

(defun win-move (window x y &key relative)
  "Wrapper for croatoan:move-window"
  (with-croatoan-window (inner window)
    (c:move-window inner y x :relative relative)))

(defun win-resize (window width height)
  "Wrapper for croatoan:resize"
  (with-croatoan-window (inner window)
    (c:resize inner height width)))

(defun win-show (window)
  "Show a window (must be stacked, see croatoan)"
  (with-croatoan-window (inner window)
    (setf (c:visiblep inner) t)))

(defun win-hide (window)
  "Hide a window (must be stacked, see croatoan)"
  (with-croatoan-window (inner window)
    (setf (c:visiblep inner) nil)))

(defun win-shown-p (window)
  "Show a window (must be stacked, see croatoan)"
  (with-croatoan-window (inner window)
    (c:visiblep inner)))

(defun win-set-background (window bg)
  "Set window background
   - window an instance of 'wrapper-window';
   - bg the returns value of 'tui-utils:make-win-background'"
  (with-croatoan-window (inner window)
    (setf (c:background inner) bg)))

(defgeneric print-text (object text x y &key &allow-other-keys)
  (:documentation "Print text on object (usually a window)"))

(defgeneric refresh-config (object)
  (:documentation "This  function will reload the configuration (from
  files) and reshape/redraw `object' accordly"))

(defgeneric calculate (object dt)
  (:documentation "Do something as dt time passed"))

(defgeneric draw (object)
  (:documentation "Draw object"))

(defgeneric aabb (object))

(defmethod refresh-config (object)
  object)

(defmethod refresh-config ((object null))
  object)

(defmethod  print-text ((object wrapper-window) (text string) x y
                        &key
                          (attributes nil)
                          (fgcolor    nil)
                          (bgcolor    nil)
                          &allow-other-keys)
  (print-text object
              (make-tui-string text
                               :attributes attributes
                               :fgcolor    fgcolor
                               :bgcolor    bgcolor)
              x y))

(defmethod print-text ((object wrapper-window) (text c:complex-string) x y
                       &key &allow-other-keys)
  (c:add (croatoan-window object) text :x x :y y))

(defmethod print-text ((object wrapper-window) (text character) x y
                       &key
                         (attributes nil)
                         (fgcolor    nil)
                         (bgcolor    nil)
                         &allow-other-keys)
  (c:add (croatoan-window object)
         (string text)
         :x          x
         :y          y
         :attributes attributes
         :bgcolor    bgcolor
         :fgcolor    fgcolor))

(defmethod print-text ((object wrapper-window) (text list) x y &key &allow-other-keys)
  (loop
     for block in text
     with current-x = x do
       (c:add (croatoan-window object)
              block
              :x current-x
              :y y)
       (incf current-x (text-length block)))
  object)

(defmethod print-text ((object wrapper-window) text x y &key &allow-other-keys)
  (print-text object (to-s text) x y))

(defmethod calculate (object dt)
  (declare (ignore object dt))
  t)

(defmethod calculate ((object null) dt)
  (declare (ignore object dt))
  t)

(defmethod draw (object)
  (declare (ignore object))
  t)

(defmethod draw ((object null))
  (declare (ignore object))
  t)

(defmethod aabb ((object wrapper-window))
  (let ((x (win-x      object))
        (y (win-y      object))
        (w (win-width  object))
        (h (win-height object)))
    (2d-utils:make-iaabb2 x y (1- (+ x w)) (1- (+ y h)))))

(defun remove-intersecting-window (&key (discarded-window-type '()))
  (labels ((copy-subwindows-stack ()
             (let ((copy '()))
               (do-stack-element (w *window-stack*)
                 (when (and (win-visible-p w)
                            (not (find-if (lambda (a) (typep w a))
                                          discarded-window-type)))
                   (push w copy)))
               copy))
           (%remove-intersecting-window (&optional
                                           (windows (copy-subwindows-stack))
                                           (checked '()))
             (if (null windows)
                 checked
                 (let* ((probe-window (first windows))
                        (aabb-probe (aabb probe-window)))
                   (setf windows (remove probe-window windows))
                   (loop for i in windows do
                     (let ((aabb (aabb i)))
                       (when (2d-utils:iaabb2-intersect-p aabb-probe aabb)
                         (setf windows (remove i windows)))))
                   (%remove-intersecting-window windows (push probe-window checked))))))
    (let ((visible-windows (%remove-intersecting-window)))
      (sort visible-windows
            (lambda (a b)
              (if (= (win-y a) (win-y b))
                  (< (win-x a) (win-x b))
                  (< (win-y a) (win-y b))))))))

(defun calculate-all (dt)
  (do-stack-element (window *window-stack*)
    (when (win-visible-p window)
      (win-touch window)
      (c:mark-for-refresh (croatoan-window window)))
    (calculate window dt))
  (c:refresh-marked))

(defun draw-all (&key (clear t))
  (let ((to-be-drawn (remove-intersecting-window)))
    (loop for window in to-be-drawn do
      (when (win-visible-p window)
        (when clear
          (win-clear window))
        (draw window)))))

(defun refresh-config-all ()
  (if command-line:*gemini-full-screen-mode*
      (progn
        (refresh-config *main-window*)
        (refresh-config *gemini-toc-window*)
        (refresh-config *thread-window*)
        (refresh-config *message-window*)
        (refresh-config *tags-window*)
        (refresh-config *conversations-window*)
        (refresh-config *command-window*)
        (refresh-config *send-message-window*)
        (refresh-config *chats-list-window*)
        (refresh-config *open-message-link-window*))
      (progn
        (refresh-config *main-window*)
        (refresh-config *thread-window*)
        (refresh-config *message-window*)
        (refresh-config *tags-window*)
        (refresh-config *conversations-window*)
        (refresh-config *command-window*)
        (refresh-config *send-message-window*)
        (refresh-config *chats-list-window*)
        (refresh-config *gemini-toc-window*)
        (refresh-config *open-message-link-window*))))

(defun cursor-show ()
  (setf (c:cursor-visible-p (croatoan-window *main-window*)) t))

(defun cursor-hide ()
  (setf (c:cursor-visible-p (croatoan-window *main-window*)) nil))

(defun refresh-config-colors (window conf-key)
  (let ((bg (swconf:win-bg conf-key))
        (fg (swconf:win-fg conf-key)))
    (with-croatoan-window (croatoan-window window)
      (setf (c:background croatoan-window) (tui:make-win-background bg))
      (setf (c:bgcolor    croatoan-window) bg)
      (setf (c:fgcolor    croatoan-window) fg))
    window))

(defun refresh-config-sizes (window conf-key)
  (let ((raw-height (swconf:win-height conf-key))
        (raw-width  (swconf:win-width  conf-key)))
    (with-croatoan-window (croatoan-window window)
      (c:resize croatoan-window
                (main-window:parse-subwin-h raw-height)
                (main-window:parse-subwin-w raw-width))
      window)))

(defun add-flush-left-text (window message y-start
                            &key
                              (bgcolor         nil)
                              (fgcolor         nil)
                              (attributes      nil)
                              (process-line-fn #'identity)
                              (has-border-p    nil)
                              (padding         1))
  "Add fitted lines generated from  `message' to `window' starting from row `y-start'.

Note that the window will expand its height to accomodate the text.

`process-line-fn` is  a function (default #'identity)  that is applied
to  each   line  of  processed   text  (not  the   original  message),
`has-border-p` if non nil will pust  padding in the windth of the text
to  take into  account  the border.  You can  add  extra padding  with
`padding' (default: 1)."
  (let* ((actual-y-start  (if has-border-p
                              (1+ y-start)
                              y-start))
         (actual-x        (if has-border-p
                              (1+ padding)
                              padding))
         (width           (if has-border-p
                              (- (win-width window) padding 2)
                              (- (win-width window) padding)))
         (words           (text-utils:split-words message))
         (message-lines   (text-utils:flush-left-mono-text words width))
         (height-lines    (length message-lines))
         (actual-window-h (calc-bottom-of-window-height window
                                                        :has-border-p has-border-p))
         (expand-height-p (> height-lines
                             actual-window-h)))
    (when expand-height-p
      (win-resize window
                  (win-width window)
                  (+ (win-height window)
                     (- height-lines
                        actual-window-h))))
    (loop
       for line in message-lines
       for y from actual-y-start do
         (print-text window
                     (funcall process-line-fn line)
                     actual-x
                     y
                     :bgcolor    bgcolor
                     :fgcolor    fgcolor
                     :attributes attributes))))

(defun make-blocking-message-dialog (screen parent title message-lines bg fg)
  "Make a  dialog that block  all other threads, `message-lines'  is a
list of strings (the text lines)."
  (let* ((low-level-window (make-blocking-croatoan-window))
         (window           (make-instance 'wrapper-window
                                          :parent          parent
                                          :croatoan-window low-level-window))
         (win-w            (max (+ 4 (length title))
                                (+ 2 (tui:find-max-line-width message-lines))))
         (win-h            (+ 2 (length message-lines)))
         (x                (truncate (- (/ (win-width screen) 2)
                                        (/ win-w 2))))
         (y                (truncate (- (/ (win-height screen) 2)
                                        (/ win-h 2)))))
    (setf (c:background low-level-window) (tui:make-win-background bg))
    (setf (c:bgcolor low-level-window)    bg)
    (setf (c:fgcolor low-level-window)    fg)
    (win-resize window win-w win-h)
    (win-move   window x y)
    (win-box window)
    (print-text window title 2 0)
    (loop
       for line in message-lines
       for y from 1 do
         (print-text window line 1 y))
    (win-refresh window)
    (c:get-char low-level-window)
    (win-close window)))

(defun make-dialog (parent title message style
                    &optional (buttons nil)
                      (append-ok-button t))
  (let* ((lines          (text-utils:split-lines message))
         (actual-buttons (if append-ok-button
                             (append (list +menu-button-ok+)
                                     buttons)
                             buttons))
         (message        (join-with-strings lines (format nil "~%")))
         (dialog-window  (make-instance 'c-dlg:msgbox
                                        :parent               parent
                                        :stacked              nil
                                        :center               t
                                        :message              message
                                        :input-blocking       t
                                        :style                style
                                        :wrap-message         t
                                        :enable-function-keys t
                                        :title                title
                                        :buttons              actual-buttons)))
    (make-instance 'wrapper-window
                   :croatoan-window dialog-window)))

(defun make-simple-dialog-style (fg bg)
   `(:foreground (:fgcolor ,fg  :bgcolor ,bg)
     :background (:fgcolor ,fg  :bgcolor ,bg)
     :title (:fgcolor ,fg :bgcolor ,bg)
     c:label  (:foreground (:fgcolor ,fg :bgcolor ,bg))
     c:button (:border              (:fgcolor ,bg)
               :foreground          (:fgcolor ,fg)
               :selected-border     (:fgcolor ,fg)
               :selected-background (:bgcolor ,bg))))

(defun make-error-message-dialog (parent title message
                                  &optional
                                    (buttons nil)
                                    (append-ok-button t))
  (let* ((bg    (swconf:win-bg swconf:+key-error-dialog+))
         (fg    (swconf:win-fg swconf:+key-error-dialog+))
         (style (make-simple-dialog-style fg bg)))
    (make-dialog parent title message style buttons append-ok-button)))

(defun make-info-message-dialog (parent title message
                                 &optional
                                   (buttons nil)
                                   (append-ok-button t))
  (let* ((bg (swconf:win-bg swconf:+key-info-dialog+))
         (fg (swconf:win-fg swconf:+key-info-dialog+))
         (style (make-simple-dialog-style fg bg)))
    (make-dialog parent title message style buttons append-ok-button)))

(defun make-simple-style (foreground          background
                          selected-foreground selected-background)
  "Croatoan (ncurses) use a style to apply colors on a windows and its
content, this function generate a styele object (a plist) suitable for
the library."
  (list :foreground
        (list :fgcolor foreground          :bgcolor background)
        :background
        (list :fgcolor foreground          :bgcolor background)
        :selected-foreground
        (list :fgcolor selected-foreground :bgcolor selected-background)
        :selected-background
        (list :fgcolor selected-foreground :bgcolor selected-background)))

(defun style-class->list (style)
  (make-simple-style (swconf:input-foreground    style)
                     (swconf:input-background    style)
                     (swconf:selected-foreground style)
                     (swconf:selected-background style)))

(defun make-input-dialog (screen parent message)
  "A  dialog window  with  a  single input  field,  returns the  input
inserted by the user"
  (with-croatoan-window (screen-low-level screen)
    (let* ((theme-style      (swconf:form-style swconf:+key-input-dialog+))
           (style-form       (style-class->list theme-style))
           (fg               (swconf:foreground theme-style))
           (bg               (swconf:background theme-style))
           (window-width     (truncate (/ (win-width parent)
                                          4)))
           (window-height    (truncate (/ (win-height parent)
                                          4)))
           (field-width      (- window-width 4))
           (window-position  (list (truncate (- (/ (win-height parent) 2)
                                                (/ window-height 2)))
                                   (truncate (- (/ (win-width  parent) 2)
                                                (/ window-width 2)))))
           (button-cancel    (make-instance 'c:button
                                            :name     :b-cancel
                                            :title    (_ "Cancel")
                                            :callback 'c:cancel
                                            :position (list (truncate (1+ (* window-height
                                                                             3/4)))
                                                            2)))
           (button-accept    (make-instance 'c:button
                                            :name     :b-accept
                                            :title    (_ "OK")
                                            :callback 'c:accept
                                            :position (list (truncate (* window-height 3/4))
                                                            2)))
           (field            (make-instance 'c:field
                                            :position (list (truncate (* window-height 1/2))
                                                            2)
                                            :width    field-width))
           (low-level-window (make-instance 'c:form-window
                                            :stacked        nil
                                            :input-blocking t
                                            :width          window-width
                                            :height         window-height
                                            :position       window-position
                                            :insert-mode    t
                                            :border         t
                                            :elements       (list field
                                                                  button-accept
                                                                  button-cancel)
                                            :style          (list 'field  style-form
                                                                  'button style-form
                                                                  'label  style-form)))
           (window           (make-instance 'wrapper-window
                                            :croatoan-window low-level-window)))
      (win-set-background window (make-win-background bg :color-fg fg))
      (add-flush-left-text window message 2 :has-border-p t)
      (win-refresh window)
      (setf (c:cursor-visible-p screen-low-level) t)
      (let ((res (croatoan:edit low-level-window)))
        (setf (c:cursor-visible-p screen-low-level) nil)
        (win-close window)
        (if (null res)
            :canceled
            (c:value field))))))

(defun make-checklist-dialog (screen parent title options)
  (with-croatoan-window (screen-low-level screen)
    (let* ((theme-style      (swconf:form-style swconf:+key-input-dialog+))
           (fg               (swconf:foreground theme-style))
           (bg               (swconf:background theme-style))
           (window-width     (truncate (/ (win-width parent)
                                          4)))
           (window-height    (truncate (/ (win-height parent)
                                          4)))
           (window-position  (list (truncate (- (/ (win-height parent) 2)
                                                (/ window-height 2)))
                                   (truncate (- (/ (win-width  parent) 2)
                                                (/ window-width 2)))))
           (button-cancel    (make-instance 'button
                                            :name     :b-cancel
                                            :title    (_ "Cancel")
                                            :position (list (truncate (1+ (* window-height
                                                                             3/4)))
                                                            2)))
           (button-accept    (make-instance 'button
                                            :name     :b-accept
                                            :title    (_ "OK")
                                            :position (list (truncate (* window-height 3/4))
                                                            2)))
           (low-level-window (make-instance 'menu-window
                                            :width                window-width
                                            :height               window-height
                                            :items                options
                                            :position             window-position
                                            :title                title
                                            :border               t
                                            :input-blocking       t
                                            :enable-function-keys t
                                            :menu-type            :checklist
                                            :color-pair           (list fg bg)))
            (window           (make-instance 'wrapper-window
                                             :croatoan-window low-level-window)))
      (win-set-background window (make-win-background bg :color-fg fg))
      (win-refresh        window)
      (setf (c:callback button-accept) 'accept)
      (setf (c:callback button-cancel) 'cancel)
      (setf (c:cursor-visible-p screen-low-level) t)
      (let ((results (c:select low-level-window)))
        (win-close window)
        (win-clear screen)
        (draw-all)
        (and results
             (mapcar #'c:value results))))))

(defclass focus-marked-window ()
  ((in-focus
    :initform nil
    :initarg  :in-focus
    :reader   in-focus-p
    :writer   (setf in-focus)
    :documentation "Sets check if this windows got focus")
   (focus-mark
    :initform "*"
    :initarg  :focus-mark
    :accessor focus-mark
    :documentation "the visual text to mark the focused window"))
  (:documentation "This is a window that can be marked visually when gets focus"))

(defmethod refresh-config :after ((object focus-marked-window))
  (multiple-value-bind (bg fg value)
      (swconf:config-win-focus-mark)
    (setf (focus-mark object)
          (make-tui-string value :fgcolor fg :bgcolor bg))))

(definline draw-focus-mark (window)
  (with-accessors ((in-focus-p   in-focus-p)
                   (focus-mark focus-mark)) window
    (when (in-focus-p window)
      (print-text window focus-mark 0 0))))

(defmethod draw :after ((object focus-marked-window))
  (draw-focus-mark object))

(defclass border-window ()
  ((uses-border-p
    :initform nil
    :initarg  :uses-border-p
    :reader   uses-border-p))
  (:documentation "This is a window that has a border."))

(defun window-uses-border-p (window)
  (and window
       (typep window 'border-window)
       (uses-border-p window)))

(defgeneric usable-window-width (object))

(defmethod  usable-window-width ((object border-window))
  (if (uses-border-p object)
      (win-width-no-border object)
      (win-width           object)))

(defmethod draw :after ((object border-window))
  (when (uses-border-p object)
    (win-box object)))

(defclass title-window ()
  ((title
    :initform ""
    :initarg  :title
    :accessor title
    :documentation "The actual title")
   (title-padding-left
    :initform 3
    :initarg  :title-padding-left
    :accessor title-padding-left
    :documentation "left padding text for title")
   (left-stopper
    :initform ""
    :initarg  :left-stopper
    :accessor left-stopper
    :documentation "The text before the actual title")
   (right-stopper
    :initform ""
    :initarg  :right-stopper
    :accessor right-stopper
    :documentation "The text after the actual title"))
  (:documentation "This is a window that dplays a title

 ---border--- left-stopper title-padding-left right-stopper ---border---"))

(defmethod refresh-config :after ((object title-window))
  (multiple-value-bind (left-mark right-mark padding)
      (swconf:window-titles-ends)
    (with-accessors ((left-stopper       left-stopper)
                     (right-stopper      right-stopper)
                     (title-padding-left title-padding-left)) object
      (setf title-padding-left padding)
      (setf left-stopper       left-mark)
      (setf right-stopper      right-mark)))
  object)

(defun ellipsize-title (window title)
  (with-accessors ((left-stopper       left-stopper)
                   (right-stopper      right-stopper)
                   (title-padding-left title-padding-left)) window
    (let ((clean-title (ellipsize (trim-blanks title)
                                  (truncate (- (win-width window)
                                               (length left-stopper)
                                               (length right-stopper)
                                               title-padding-left)))))
      clean-title)))

(defmethod draw :after ((object title-window))
  (with-accessors ((left-stopper       left-stopper)
                   (right-stopper      right-stopper)
                   (title-padding-left title-padding-left)
                   (title              title)) object
    (print-text object left-stopper                    title-padding-left 0)
    (print-text object (ellipsize-title object title)  nil                nil)
    (print-text object right-stopper                   nil                nil)))

(defun adjust-win-vertical-positioning-if-gemini-fullscreen (window)
  (when command-line:*gemini-full-screen-mode*
    (with-croatoan-window (croatoan-window window)
      (let* ((reference-window *gemini-toc-window*)
             (width            (- (win-width *main-window*)
                                  (win-width reference-window)))
             (x                (win-width reference-window)))
        (c:resize croatoan-window (win-height window) width)
        (win-move window x (win-y window))))))