[STUMP] Menu scrolling

[Vitaly Mayatskikh]

Hi!

I want to give another spin to patch which Morgan posted here 2 or 3
years ago. This patch adds ability to make menus scrollable, if all
contents can not fit into menu.

For example, with vanilla StumpWM when you open large mpd collection
menu (with contribs/mpd.lisp), the menu window stretches far away the
screen. After you apply patch you'll see nice cute small menu which
scroll up and down when cursor reaches the borders.

I use this patch since the very beginning and did not notice even
single problem.

If there's no objections, I'll commit it finally.

diff --git a/menu.lisp b/menu.lisp
index 4f77a04..4474ff5 100644
--- a/menu.lisp
+++ b/menu.lisp
@@ -50,15 +50,53 @@
 (defvar *current-menu-input* nil)
 
 (defstruct menu-state
-  table prompt selected)
+  table prompt selected view-start view-end)
+
+(defun menu-scrolling-required-p (menu)
+  (and *menu-maximum-height*
+       (> (length (menu-state-table menu))
+          *menu-maximum-height*)))
 
 (defun bound-check-menu (menu)
+  "Adjust the menu view and selected item based
+on current view and new selection."
   (setf (menu-state-selected menu)
         (cond ((< (menu-state-selected menu) 0)
                (1- (length (menu-state-table menu))))
               ((>= (menu-state-selected menu) (length (menu-state-table menu)))
                0)
-              (t (menu-state-selected menu)))))
+              (t (menu-state-selected menu))))
+  (when (menu-scrolling-required-p menu)
+    (progn (cond ((< (menu-state-selected menu) *menu-maximum-height*)
+                  (progn (setf (menu-state-view-start menu) 0)
+                         (setf (menu-state-view-end menu)
+                               *menu-maximum-height*)))
+                 ((> (menu-state-selected menu)
+                     (- (length (menu-state-table menu))
+                        *menu-maximum-height*))
+                  (progn (setf (menu-state-view-start menu)
+                               (- (length (menu-state-table menu))
+                                  *menu-maximum-height*))
+                         (setf (menu-state-view-end menu)
+                               (length (menu-state-table menu)))))
+                 ((< (menu-state-selected menu)
+                      (menu-state-view-start menu))
+                  (progn (setf (menu-state-view-start menu)
+                               (- (menu-state-selected menu)
+                                  *menu-scrolling-step*))
+                         (setf (menu-state-view-end menu)
+                               (- (+ (menu-state-selected menu)
+                                     *menu-maximum-height*)
+                                 *menu-scrolling-step*))))
+                 ((>= (menu-state-selected menu)
+                      (menu-state-view-end menu))
+                  (progn (setf (menu-state-view-start menu)
+                               (+ (- (menu-state-selected menu)
+                                     *menu-maximum-height*)
+                                  *menu-scrolling-step*))
+                         (setf (menu-state-view-end menu)
+                               (+ (menu-state-selected menu)
+                                  *menu-scrolling-step*))))))))
 
 (defun menu-up (menu)
   (setf *current-menu-input* "")
@@ -115,9 +153,13 @@ backspace or F9), return it otherwise return nil"
        (when (and (>= (length cur-elem-name) current-input-length)
                   (ppcre:scan match-regex cur-elem-name))
          (setf (menu-state-selected menu) cur-pos)
+          (bound-check-menu menu)
          (return))))))
 
-(defun select-from-menu (screen table &optional prompt (initial-selection 0))
+;; TODO: The maximum lines-number should be customizable or at least based on
+;; TODO: screen height
+(defun select-from-menu (screen table &optional prompt
+                                                (initial-selection 0))
   "Prompt the user to select from a menu on SCREEN. TABLE can be
 a list of values or an alist. If it's an alist, the CAR of each
 element is displayed in the menu. What is displayed as menu items
@@ -128,27 +170,56 @@ See *menu-map* for menu bindings."
   (check-type table list)
   (check-type prompt (or null string))
   (check-type initial-selection integer)
-  (let* ((menu (make-menu-state
+  (let* ((menu-options (mapcar (lambda (elt)
+                                 (if (listp elt)
+                                     (first elt)
+                                   elt))
+                               table))
+         (menu-require-scrolling (and *menu-maximum-height*
+                                       (> (length menu-options)
+                                          *menu-maximum-height*)))
+         (menu (make-menu-state
                 :table table
                 :prompt prompt
+                :view-start (if menu-require-scrolling
+                                initial-selection
+                              0)
+                :view-end (if menu-require-scrolling
+                              (if (< (+ initial-selection
+                                        *menu-maximum-height*)
+                                     (length menu-options))
+                                  (+ initial-selection
+                                     *menu-maximum-height*)
+                                (- (length menu-options)
+                                   *menu-maximum-height*))
+                            (length menu-options))
                 :selected initial-selection))
-         (menu-options (mapcar #'menu-element-name
-                               table))
-         (menu-text (if prompt
-                        (cons prompt menu-options)
-                        menu-options))
          (*record-last-msg-override* t)
-         (*suppress-echo-timeout* t)
-        (*current-menu-input* ""))
+         (*suppress-echo-timeout* t))
     (bound-check-menu menu)
     (catch :menu-quit
       (unwind-protect
            (with-focus (screen-key-window screen)
              (loop
-                (echo-string-list screen menu-text
-                                  (+ (menu-state-selected menu) (if prompt 1 
0)))
+                (let* ((menu-view (subseq menu-options (menu-state-view-start 
menu) (menu-state-view-end menu)))
+                   (menu-text (let ((view-text menu-view))
+                                (unless (= 0 (menu-state-view-start menu))
+                                  (setf view-text
+                                        (cons "..." view-text)))
+                                (unless (= (length menu-options) 
(menu-state-view-end menu))
+                                  (setf view-text (append view-text '("..."))))
+                                (when prompt
+                                  (setf view-text
+                                        (cons prompt view-text)))
+                                view-text))
+                   (menu-highlight (+ (- (menu-state-selected menu)
+                                         (menu-state-view-start menu))
+                                      (if prompt 1 0)
+                                      (if (= 0 (menu-state-view-start menu)) 0 
1))))
+              (echo-string-list screen menu-text menu-highlight))
                 (multiple-value-bind (action key-seq) (read-from-keymap (list 
*menu-map*))
                  (if action
                      (funcall action menu)
                      (check-menu-complete menu (first key-seq))))))
         (unmap-all-message-windows)))))
+
diff --git a/primitives.lisp b/primitives.lisp
index 10ca8df..ee505ab 100644
--- a/primitives.lisp
+++ b/primitives.lisp
@@ -235,6 +235,13 @@ the mode-line, the button clicked, and the x and y of the 
pointer.")
 (defvar *text-color* "white"
   "The color of message text.")
 
+(defvar *menu-maximum-height* nil
+  "Defines the maxium number of lines to display in the menu before enabling
+   scrolling. If NIL scrolling is disabled.")
+
+(defvar *menu-scrolling-step* 1
+  "Number of lines to scroll when hitting the menu list limit.")
+
 (defparameter +netwm-supported+
   '(:_NET_SUPPORTING_WM_CHECK
     :_NET_NUMBER_OF_DESKTOPS

-- 
wbr, Vitaly