XEmacs 21.2.14.

[chise/xemacs-chise.git.1] / lisp / x-font-menu.el

diff --git a/lisp/x-font-menu.el b/lisp/x-font-menu.el
index 9a1db5c..d96fe11 100644 (file)
--- a/lisp/x-font-menu.el
+++ b/lisp/x-font-menu.el
@@ -130,18 +130,45 @@
 ;;; (defvar font-menu-ignore-proportional-fonts nil
 ;;;   "*If non-nil, then the font menu will only show fixed-width fonts.")
 
+(defgroup font-menu ()
+  "Settings for the font menu"
+  :group 'x)
+
 ;;;###autoload
 (defcustom font-menu-ignore-scaled-fonts t
   "*If non-nil, then the font menu will try to show only bitmap fonts."
   :type 'boolean
-  :group 'x)
+  :group 'font-menu)
 
 ;;;###autoload
 (defcustom font-menu-this-frame-only-p nil
   "*If non-nil, then changing the default font from the font menu will only
 affect one frame instead of all frames."
   :type 'boolean
-  :group 'x)
+  :group 'font-menu)
+
+(defcustom font-menu-max-items 25
+  "*Maximum number of items in the font menu
+If number of entries in a menu is larger than this value, split menu
+into submenus of nearly equal length.  If nil, never split menu into
+submenus."
+  :group 'font-menu
+  :type '(choice (const :tag "no submenus" nil)
+                (integer)))
+
+(defcustom font-menu-submenu-name-format "%-12.12s ... %.12s"
+  "*Format specification of the submenu name.
+Used by `font-menu-split-long-menu' if the number of entries in a menu is
+larger than `font-menu-menu-max-items'.
+This string should contain one %s for the name of the first entry and
+one %s for the name of the last entry in the submenu.
+If the value is a function, it should return the submenu name.  The
+function is be called with two arguments, the names of the first and
+the last entry in the menu."
+  :group 'font-menu
+  :type '(choice (string :tag "Format string")
+                (function)))
+
 
 ;; only call XListFonts (and parse) once per device.
 ;; ( (device . [parsed-list-fonts family-menu size-menu weight-menu]) ...)
@@ -358,6 +385,40 @@ or if you change your font path, you can call this to re-initialize the menus."
       
     (vector entry family size weight slant)))
 
+(defun font-menu-split-long-menu (menu)
+  "Split MENU according to `font-menu-max-items'."
+  (let ((len (length menu)))
+    (if (or (null font-menu-max-items)
+           (null (featurep 'lisp-float-type))
+           (<= len font-menu-max-items))
+       menu
+      ;; Submenu is max 2 entries longer than menu, never shorter, number of
+      ;; entries in submenus differ by at most one (with longer submenus first)
+      (let* ((outer (floor (sqrt len)))
+            (inner (/ len outer))
+            (rest (% len outer))
+            (result nil))
+       (setq menu (reverse menu))
+       (while menu
+         (let ((in inner)
+               (sub nil)
+               (to (car menu)))
+           (while (> in 0)
+             (setq in   (1- in)
+                   sub  (cons (car menu) sub)
+                   menu (cdr menu)))
+           (setq result
+                 (cons (cons (if (stringp font-menu-submenu-name-format)
+                                 (format font-menu-submenu-name-format
+                                         (aref (car sub) 0) (aref to 0))
+                               (funcall font-menu-submenu-name-format
+                                        (aref (car sub) 0) (aref to 0)))
+                             sub)
+                       result)
+                 rest  (1+ rest))
+           (if (= rest outer) (setq inner (1+ inner)))))
+       result))))
+
 ;;;###autoload
 (defun font-menu-family-constructor (ignored)
   (catch 'menu
@@ -376,21 +437,28 @@ or if you change your font path, you can call this to re-initialize the menus."
       ;; the same size and weight as the current font (scalable fonts
       ;; exist in every size).  Only the current font is marked as
       ;; selected.
-      (mapcar
-       (lambda (item)
-        (setq f (aref item 0)
-              entry (vassoc f (aref dcache 0)))
-        (if (and (member weight (aref entry 1))
-                 (or (member size (aref entry 2))
-                     (and (not font-menu-ignore-scaled-fonts)
-                          (member 0 (aref entry 2)))))
-            (enable-menu-item item)
-          (disable-menu-item item))
-        (if (string-equal family f)
-            (select-toggle-menu-item item)
-          (deselect-toggle-menu-item item))
-        item)
-       (aref dcache 1)))))
+      (font-menu-split-long-menu
+       (mapcar
+       (lambda (item)
+         (setq f (aref item 0)
+               entry (vassoc f (aref dcache 0)))
+         ;; The user can no longer easily control the weight using the menu
+         ;; Note it is silly anyway as it could very well be that the font
+         ;; has no common size+weight combinations with the default font.
+;;       (if (and (member weight (aref entry 1))
+;;                (or (member size (aref entry 2))
+;;                    (and (not font-menu-ignore-scaled-fonts)
+;;                         (member 0 (aref entry 2)))))
+;;           (enable-menu-item item)
+;;         (disable-menu-item item))
+         (if (and font-menu-ignore-scaled-fonts (member 0 (aref entry 2)))
+             (disable-menu-item item)
+           (enable-menu-item item))      
+         (if (string-equal family f)
+             (select-toggle-menu-item item)
+           (deselect-toggle-menu-item item))
+         item)
+       (aref dcache 1))))))
 
 ;;;###autoload
 (defun font-menu-size-constructor (ignored)