tinmop/src/line-oriented-window.lisp

;; tinmop: an humble gemini and pleroma client
;; Copyright (C) 2020,2021  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 :line-oriented-window)

(defclass line ()
  ((selected-fg
    :initform :black
    :initarg  :selected-fg
    :accessor selected-fg
    :documentation "The foreground color for a selected line")
   (selected-bg
    :initform :cyan
    :initarg  :selected-bg
    :accessor selected-bg
    :documentation "The background color for a selected line")
   (normal-fg
    :initform :cyan
    :initarg  :normal-fg
    :accessor normal-fg
    :documentation "The foreground color for a line")
   (normal-bg
    :initform :black
    :initarg  :normal-bg
    :accessor normal-bg
    :documentation "The background color for a line")
   (normal-text
    :initform (make-tui-string "…")
    :initarg  :normal-text
    :accessor normal-text
    :documentation "The actual not selected text")
   (selected-text
    :initform (make-tui-string "…")
    :initarg  :selected-text
    :accessor selected-text
    :documentation "The actual selected text")
   (deleted-text
    :initform (make-tui-string "…")
    :initarg  :deleted-text
    :accessor deleted-text
    :documentation "The actual deleted text ")
   (fields
    :initform ()
    :initarg  :fields
    :accessor fields
    :documentation "A generic plist of useful informations for the window")
   (index
    :initform 0
    :initarg  :index
    :accessor index
    :documentation "The index of this line in the window")
   (selected
    :initform nil
    :initarg  :selected
    :reader   selectedp
    :writer (setf selected)
    :documentation "Non nil if this line is selected state"))
  (:documentation "This class represents a single line in a row-oriented-widget"))

(defmethod print-object ((object line) stream)
  (format stream "line: ~s" (tui-string->chars-string (normal-text object))))

(defclass row-oriented-widget ()
  ((rows
    :initform ()
    :initarg  :rows
    :accessor rows
    :documentation "The rows of data for this widget")
   (row-selected-index
    :initform 0
    :initarg  :row-selected-index
    :accessor row-selected-index
    :documentation "The index of the selected row")
   (single-row-height
    :initform 1
    :initarg  :single-row-height
    :accessor single-row-height
    :documentation "The height of a row (in character)")
   (top-row-padding
    :initform 0
    :initarg  :top-row-padding
    :accessor top-row-padding
    :documentation "the  padding from  the top of  the window  and the
    position where to draw the first line")
   (current-row-index
    :initform 0
    :initarg  :current-row-index
    :accessor current-row-index
    :documentation "The active line index")
   (y-current-row
    :initform 0
    :initarg  :y-current-row
    :accessor y-current-row
    :documentation "The active line position")
   (top-rows-slice
    :initform 0
    :initarg  :top-rows-slice
    :accessor top-rows-slice
    :documentation "The start index of the visible rows")
   (bottom-rows-slice
    :initform 0
    :initarg  :bottom-rows-slice
    :accessor bottom-rows-slice
    :documentation "The start index of the visible rows"))
  (:documentation "A widget that holds a selectable list of lines"))

(defmethod initialize-instance :after ((object row-oriented-widget) &key &allow-other-keys)
  (with-accessors ((top-row-padding top-row-padding)
                   (y-current-row   y-current-row)) object
    (setf y-current-row top-row-padding)))

(defmethod (setf top-row-padding) ((object row-oriented-widget) new-padding)
  (setf (slot-value object 'top-row-padding) new-padding)
  (setf (slot-value object 'y-current-row)   new-padding)
  object)

(defgeneric renderizable-rows-data (object))

(defgeneric unselect-all (object))

(defgeneric select-row (object index))

(defgeneric select-first-row (object))

(defgeneric adjust-selected-rows (object strategy))

(defgeneric selected-row (object))

(defgeneric selected-row-fields (object))

(defgeneric selected-row-delete (object))

(defgeneric search-row (object regex &key redraw))

(defgeneric row-move (object amount)
  (:documentation "Move selected line of 'amount'. 'Amount' can be
  an integer number, if positive increase the position of the selected
  line otherwise decrease, relative to current index position.
  The value is clamped at range [ 0, '(length (rows object)))' ).
  This function return the number of positions acually moved"))

(defgeneric update-all-rows (object new-rows))

(defgeneric append-new-rows (object new-rows))

(defgeneric map-rows (object function &key &allow-other-keys))

(defgeneric rows-map-raw (object function &key &allow-other-keys))

(defgeneric rows-length (object &key &allow-other-keys))

(defgeneric rows-empty-p (object &key &allow-other-keys))

(defgeneric rows-remove-if (object function &key &allow-other-keys))

(defgeneric rows-find-if (object function &key from-end start end key &allow-other-keys))

(defgeneric rows-safe-subseq (object start &key end &allow-other-keys))

(defgeneric rows-elt (object index &key &allow-other-keys))

(defgeneric rows-last-elt (object &key &allow-other-keys))

(defgeneric rows-first-elt (object &key &allow-other-keys))

(defgeneric rows-position-if (object predicate &key from-end start end key &allow-other-keys))

(defmethod renderizable-rows-data ((object row-oriented-widget))
  "Cut from all the lines a slice that that fits into the widget"
  (with-accessors ((top-row-padding    top-row-padding)
                   (current-row-index  current-row-index)
                   (row-selected-index row-selected-index)
                   (single-row-height  single-row-height)
                   (top-rows-slice     top-rows-slice)
                   (bottom-rows-slice  bottom-rows-slice)
                   (rows               rows))  object
    (let* ((window-height       (if (uses-border-p object)
                                    (win-height-no-border object)
                                    (win-height           object)))
           (available-rows      (truncate (/ (- window-height top-row-padding)
                                             single-row-height)))
           (selected-top-offset (rem row-selected-index available-rows))
           (top                 (- row-selected-index selected-top-offset))
           (bottom              (+ row-selected-index
                                   (- available-rows selected-top-offset))))
      (setf top-rows-slice    top
            bottom-rows-slice bottom)
      (values (safe-subseq rows top bottom)
              selected-top-offset))))

(defmethod unselect-all ((object row-oriented-widget))
  (loop for row in (rows object) do
       (setf (selected row) nil))
  object)

(defmethod select-row ((object row-oriented-widget) (index number))
  (with-accessors ((rows               rows)
                   (row-selected-index row-selected-index)) object
    (restart-case
        (if (or (<  index 0)
                (>= index (length rows)))
            (error 'conditions:out-of-bounds :idx index :seq rows)
            (progn
              (setf row-selected-index index)
              (setf (selected (elt rows index)) t)))
      (ignore-selecting-action (e)
        (declare (ignore e))
        nil)
      (set-default-index (e)
        (declare (ignore e))
        (setf row-selected-index 0)))
    object))

(defmethod select-first-row ((object row-oriented-widget))
  (select-row object 0))

(defun adjust-rows-select-first (window)
  (when (rows window)
    (select-first-row window)))

(defun adjust-rows-noop (window)
  window)

(defun adjust-rows-select-last (window)
  (with-accessors ((rows rows)) window
    (when rows
      (let ((height (win-height-no-border window)))
        (if (>= (rows-length window) height)
            (select-row window (- (rows-length window)
                                  height))
            (select-first-row window)))))
  window)

(defmethod adjust-selected-rows ((object row-oriented-widget) (strategy function))
  (funcall strategy object)
  object)

(defmethod selected-row ((object row-oriented-widget))
  "Return the current selected row"
  (with-accessors ((rows               rows)
                   (row-selected-index row-selected-index)) object
    (when rows
      (if (<=  0
               row-selected-index
               (1- (length rows)))
          (elt rows row-selected-index)
          nil))))

(defmethod selected-row-fields ((object row-oriented-widget))
  "Return the fields current selected row"
  (when-let ((selected-row (selected-row object)))
    (fields selected-row)))

(defmethod selected-row-delete ((object row-oriented-widget))
  "delete the selected row"
  (with-accessors ((rows               rows)
                   (row-selected-index row-selected-index)) object
    (let ((last-was-removed-p (= row-selected-index
                                 (1- (length rows)))))
      (setf rows (remove-if #'selectedp rows))
      (if rows
          (if last-was-removed-p
              (select-row object (1- row-selected-index))
              (select-row object row-selected-index))
          (setf row-selected-index 0)))
    object))

(defmethod row-move ((object row-oriented-widget) amount)
  "Navigate the lines, move the  selected row by `amount', returns the
actual of  rows moved. This can  be different from `amount'  if moving
this exact quantity would go beyond the length or rows or zero."
  (with-accessors ((rows               rows)
                   (row-selected-index row-selected-index)) object
    (if (and rows
             row-selected-index
             (/= 0 amount))
        (let* ((desired-amount (+ amount row-selected-index))
               (actual-amount  (if (< amount 0)
                                   (max (- desired-amount
                                           row-selected-index)
                                        (- row-selected-index))
                                   (- (min desired-amount
                                           (1- (length rows)))
                                      row-selected-index))))
          (select-row object (+ row-selected-index
                                actual-amount))
          actual-amount)
        0)))

(defmethod search-row ((object row-oriented-widget) regex &key (redraw t))
  (handler-case
      (with-accessors ((row-selected-index row-selected-index)) object
        (let* ((scanner        (create-scanner regex :case-insensitive-mode t))
               (selected-row                 (selected-row object))
               (selected-text                (normal-text selected-row))
               (actual-row-starting          (if (scan scanner selected-text)
                                                 (1+ row-selected-index)
                                                 row-selected-index))
               (position-found (position-if (lambda (a)
                                              (if (selectedp a)
                                                  (scan scanner (selected-text a))
                                                  (scan scanner (normal-text   a))))
                                            (safe-subseq (rows object)
                                                         actual-row-starting))))
          (when position-found
            (unselect-all object)
            (select-row object (+ actual-row-starting position-found))
            (when redraw
              (draw object))
            position-found)))
    (error ()
      (ui:error-message (_ "Invalid regular expression")))))

(defmethod update-all-rows ((object row-oriented-widget) (new-rows sequence))
  (setf (rows object) new-rows))

(defmethod append-new-rows ((object row-oriented-widget) (new-rows sequence))
  (with-slots (rows) object
    (let ((reversed-old-rows (reverse rows)))
      (loop for new-row in new-rows do
        (push new-row reversed-old-rows))
      (setf rows (reverse reversed-old-rows)))))

(defmethod append-new-rows ((object row-oriented-widget) (new-rows line))
  (append-new-rows object (list new-rows)))

(defmethod map-rows ((object row-oriented-widget) (function function)
                     &key &allow-other-keys)
  (mapcar function (rows object)))

(defmethod rows-map-raw ((object row-oriented-widget) (function function)
                     &key &allow-other-keys)
  (mapcar function (slot-value object 'rows)))

(defmacro do-rows ((object row) &body body)
  `(map nil (lambda (,row) (progn ,@body)) (rows ,object)))

(defmacro do-rows-raw ((object row) &body body)
  `(map nil (lambda (,row) (progn ,@body)) (slot-value ,object 'rows)))

(defmacro loop-rows ((object row &rest loop-clauses) &body body)
  `(loop for ,row in (rows ,object)
         ,@loop-clauses
         ,@body))

(defmethod rows-length ((object row-oriented-widget) &key &allow-other-keys)
  (length (rows object)))

(defmethod rows-empty-p ((object row-oriented-widget) &key &allow-other-keys)
  (not (rows object)))

(defmethod rows-remove-if ((object row-oriented-widget) (function function) &key &allow-other-keys)
  (remove-if function (rows object)))

(defmethod rows-find-if ((object row-oriented-widget) (predicate function)
                         &key from-end (start 0) end key &allow-other-keys)
  (find-if predicate (rows object)
           :from-end from-end
           :start    start
           :end      end
           :key      key))

(defmethod rows-safe-subseq ((object row-oriented-widget) start
                             &key (end nil) &allow-other-keys)
  (safe-subseq (rows object) start end))

(defmethod rows-elt ((object row-oriented-widget) index &key &allow-other-keys)
  (elt (rows object) index))

(defmethod rows-last-elt ((object row-oriented-widget) &key &allow-other-keys)
  (last-elt (rows object)))

(defmethod rows-first-elt ((object row-oriented-widget) &key &allow-other-keys)
  (first-elt (rows object)))

(defmethod rows-position-if ((object row-oriented-widget) (predicate function)
                             &key from-end (start 0) end key &allow-other-keys)
  (position-if predicate
               (rows object)
               :from-end from-end
               :start    start
               :end      end
               :key      key))

(defun rows->text-rows (window &key (accessor-fn #'normal-text))
  (let ((*blanks* '(#\Newline)))
    (map-rows window
              (lambda (a)
                (trim-blanks (tui:tui-string->chars-string (funcall accessor-fn a)))))))

(defun rows->text (window &key (accessor-fn #'normal-text))
  (join-with-strings (rows->text-rows window :accessor-fn accessor-fn)
                     (format nil "~%")))

(defclass simple-line-navigation-window (wrapper-window row-oriented-widget border-window)
  ((selected-line-bg
    :initform :blue
    :initarg  :selected-line-bg
    :accessor selected-line-bg
    :documentation "The background color for a selected line")
   (selected-line-fg
    :initform :red
    :initarg  :selected-line-fg
    :accessor selected-line-fg
    :documentation "The foreground color for a selected line")
   (unselected-line-bg
    :initform :blue
    :initarg  :unselected-line-bg
    :accessor unselected-line-bg
    :documentation "The background color for a unselected line")
   (unselected-line-fg
    :initform :red
    :initarg  :unselected-line-fg
    :accessor unselected-line-fg
    :documentation "The foreground color for a unselected line")
   (top-horizontal-padding
    :initform 0
    :initarg  :top-horizontal-padding
    :accessor top-horizontal-padding
    :documentation "The vertical padding (from top) of each single row"))
  (:documentation "A window that displays a navigable list of objects"))

(defmethod draw :after ((object simple-line-navigation-window))
  (with-accessors ((uses-border-p          uses-border-p)
                   (single-row-height      single-row-height)
                   (top-row-padding        top-row-padding)
                   (top-horizontal-padding top-horizontal-padding)) object
    (when-window-shown (object)
      (let ((max-line-size (if uses-border-p
                               (win-width-no-border object)
                               (win-width           object))))
        (let ((rows    (renderizable-rows-data object))
              (x       (if (uses-border-p object)
                           1
                           0))
              (y-start (if (uses-border-p object)
                           1
                           0)))
          (loop
            for y from (+ y-start
                          top-horizontal-padding
                          top-row-padding)
            by single-row-height
            for ct from 0
            for row in rows do
              (if (selectedp row)
                  (let ((tui-text (to-tui-string (selected-text row))))
                    (print-text object
                                (tui-string-apply-colors (right-pad-text (text-ellipsis tui-text
                                                                                        max-line-size)
                                                                         max-line-size)
                                                         (selected-fg row)
                                                         (selected-bg row))

                                x y))
                  (print-text object
                              (right-pad-text (text-ellipsis (normal-text row)
                                                             max-line-size)
                                              max-line-size)
                              x y
                              :bgcolor (normal-bg row)
                              :fgcolor (normal-fg row))))
          (when (> (rows-length object) 0)
            (let* ((current-selected (1+ (row-selected-index object)))
                   (pages-count-line (format nil
                                             (_ "line ~a of ~a")
                                             current-selected
                                             (rows-length object)))
                   (x-count-line     (- (win-width object)
                                        (length pages-count-line)
                                        1))
                   (y-count-line     (1- (win-height object))))
              (print-text object
                          (text-ellipsis pages-count-line (win-width-no-border object))
                          x-count-line
                          y-count-line))))))))

(defgeneric resync-rows-db (object &key redraw)
  (:documentation "Synchronize information table slot of `object` with
  table in the database, if `redraw`  is not nil redraw the object, if
  possible"))

(defmethod resync-rows-db ((object null) &key redraw)
  (declare (ignore redraw))
  t)

(defun make-blocking-list-dialog-window (screen all-fields text-lines callback
                                         &optional (title (_ "Information")))
  "Draw a  window with a scrollable list of entries, pressing enter
will fire the `callback' function (with the selected field from `all-fields'
 and text from `text-line'. This window is fitten into `screen' sizes."
  (assert (>= (length all-fields)
              (length text-lines)))
  (let* ((low-level-window  (make-blocking-croatoan-window :enable-function-keys t))
         (window-width      (max (+ 4
                                    (length title))
                                 (+ (find-max-line-width text-lines)
                                    2)))
         (window-height     (min (truncate (* 0.9 (win-height screen)))
                                 (+ (max (length text-lines)
                                         +min-shown-win-height+)
                                         2)))
         (window-x          (truncate (- (* 0.5 (win-width screen))
                                         (* 0.5 window-width))))
         (window-y          (truncate (- (* 0.5 (win-height screen))
                                         (* 0.5 window-height))))
         (bg                (swconf:win-bg swconf:+key-info-dialog+))
         (fg                (swconf:win-fg swconf:+key-info-dialog+))
         (high-level-window (make-instance 'simple-line-navigation-window
                                           :single-row-height 1
                                           :uses-border-p     t
                                           :croatoan-window   low-level-window)))
    (flet ((draw ()
             (win-clear high-level-window :redraw nil)
             (draw high-level-window)
             (print-text high-level-window title 2 0)))
      (setf (c:background low-level-window) (tui:make-win-background bg))
      (setf (c:fgcolor low-level-window) fg)
      (win-resize high-level-window window-width window-height)
      (win-move high-level-window window-x window-y)
      (setf (rows high-level-window)
            (loop
               for text in text-lines
               for fields in all-fields
               collect
                 (make-instance 'line
                                :fields        fields
                                :normal-text   text
                                :selected-text text
                                :normal-bg     bg
                                :normal-fg     fg
                                :selected-bg   fg
                                :selected-fg   bg)))
      (select-row high-level-window 0)
      (draw)
      (loop named inner
         for c = (tui:decode-key-event (c:get-wide-event low-level-window))
         while (string/= c "q")
         do
           (cond
             ((string= c :up)
              (unselect-all high-level-window)
              (row-move high-level-window -1))
             ((string= c :down)
              (unselect-all high-level-window)
              (row-move high-level-window 1))
             ((string= c "^J")
              (let ((selected-fields (selected-row-fields high-level-window))
                    (selected-text   (selected-text (selected-row high-level-window))))
                (when callback
                  (funcall callback selected-text selected-fields)))))
           (draw))
      (win-close high-level-window))))