[STUMP] [PATCH] Added scrolling to select-from-menu.

[Morgan Veyret]

diff --git a/stumpwm.asd b/stumpwm.asd
index 3e863ad..eb6ef3e 100644
--- a/stumpwm.asd
+++ b/stumpwm.asd
@@ -8,8 +8,8 @@
 ;; cmucl-clx. *very* annoying. I don't actually know if debian still
 ;; does this.
 #+cmu (progn
-         (ignore-errors (require :cmucl-clx))
-         (ignore-errors (require :clx)))
+        (ignore-errors (require :cmucl-clx))
+        (ignore-errors (require :clx)))
 ;; Otherwise just load clx
 #+sbcl(require :clx)
 
@@ -25,18 +25,18 @@
   :serial t
   :depends-on (:cl-ppcre)
   :components ((:file "package")
-              (:file "primitives")
-              (:file "keysyms")
-              (:file "keytrans")
-              (:file "kmap")
-              (:file "input")
-              (:file "core")
-              (:file "user")
+               (:file "primitives")
+               (:file "keysyms")
+               (:file "keytrans")
+               (:file "kmap")
+               (:file "input")
+               (:file "core")
+               (:file "user")
                (:file "fdump")
-              (:file "mode-line")
-              (:file "color")
-              (:file "stumpwm")
-              ;; keep this last so it always gets recompiled if
-              ;; anything changes
-              (:file "version")))
+               (:file "mode-line")
+               (:file "color")
+               (:file "stumpwm")
+               ;; keep this last so it always gets recompiled if
+               ;; anything changes
+               (:file "version")))
 
diff --git a/user.lisp b/user.lisp
index a5271fd..520d70d 100644
--- a/user.lisp
+++ b/user.lisp
@@ -1617,7 +1617,9 @@ to the next group."
   (declare (ignore menu))
   (throw :menu-quit nil))
 
-(defun select-from-menu (screen table &optional prompt (initial-selection 0))
+(defun select-from-menu (screen table &optional prompt
+                                                (initial-selection 0)
+                                                (half-view-height 10))
   "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
@@ -1637,9 +1639,6 @@ See *menu-map* for menu bindings."
                                      (first elt)
                                      elt))
                                table))
-         (menu-text (if prompt
-                        (cons prompt menu-options)
-                        menu-options))
          (*record-last-msg-override* t)
          (*suppress-echo-timeout* t))
     (bound-check-menu menu)
@@ -1647,8 +1646,36 @@ See *menu-map* for menu bindings."
       (grab-keyboard screen)
       (unwind-protect
            (loop
-            (echo-string-list screen menu-text
-                              (+ (menu-state-selected menu) (if prompt 1 0)))
+            (let* ((view-start (if (>= (- (menu-state-selected menu)
+                                          half-view-height)
+                                      0)
+                                   (- (menu-state-selected menu)
+                                      half-view-height)
+                                 0))
+                   (view-end (if (<= (+ (menu-state-selected menu)
+                                        half-view-height)
+                                    (length menu-options))
+                                 (+ view-start (* 2 half-view-height))
+                               (length menu-options)))
+                   (menu-view (loop for i
+                                    from view-start
+                                    to view-end
+                                    collect (nth i menu-options)))
+                   (menu-text (let ((view-text menu-view))
+                                (unless (= 0 view-start)
+                                  (setf view-text
+                                        (cons "..." view-text)))
+                                (unless (= (length menu-options) view-end)
+                                  (setf view-text (append view-text '("..."))))
+                                (when prompt
+                                  (setf view-text
+                                        (cons prompt view-text)))
+                                view-text))
+                   (menu-highlight (+ (- (menu-state-selected menu)
+                                         view-start)
+                                      (if prompt 1 0)
+                                      (if (= 0 view-start) 0 1))))
+              (echo-string-list screen menu-text menu-highlight))
             (let ((action (read-from-keymap *menu-map*)))
               (when action
                 (funcall action menu))))
-- 
1.5.2.2