Re: Restricting the width of the title

[Masatake YAMATO <jet@xxxxxxxx>]

> 長いタイトル [1] を *w3m* バッファの mode-line に表示すると、右
> 端が見えなくなってしまうという問題指摘があり、Emacs 22 以上でだ
> け動作するコードを commit しました。Window の幅に応じて、動的に
> 変化させています。そのためには mode-line に表示される文字の全幅
> を知る必要があるのですが、`format-mode-line' という関数は Emacs
> 21 以下や XEmacs には無く、Lisp で書くのは困難と思われます。
> 
> タイトルの幅を固定値で制限することは可能ですが、そんなユーザオプ
> ションを追加するのは気が進みません。まあ、致命的な問題ではないの
> で、放っておいても構わないと思うんですが。
> 
> [1] 例えば http://wanderphoto.com/blog/archives/2004/12/mt.html
> 

少いスペースを使って長い文字列をユーザに提示するための、ゴミコードを
持っているのですが、万が一にも役に立ちそうだったら使って下さい。添付
しているコードをevalしてみて下さい。

;; message-with-bouncing
;; message-with-rolling
;; Characters other than alphabet are not supported.
(require 'cl)
(defvar eyecatch-default-internval 0.05)
(defvar eyecatch-border-internval 1.0)

   (defface eyecatch-red '((((class color)) (:foreground "red"))) "")
   (defface eyecatch-orange '((((class color)) (:foreground "orange"))) "")
   (defface eyecatch-yellow '((((class color)) (:foreground "yellow"))) "")
   (defface eyecatch-green  '((((class color)) (:foreground "green"))) "")
   (defface eyecatch-blue   '((((class color)) (:foreground "blue"))) "")
   (defface eyecatch-purple '((((class color)) (:foreground "purple"))) "")
   (defface eyecatch-black '((((class color)) (:foreground "black"))) "")

(defvar eyecatch-faces 
  [eyecatch-black
;  eyecatch-red    
;   eyecatch-orange 
;   eyecatch-yellow 
;   eyecatch-green  
;   eyecatch-blue   
;   eyecatch-purple
    ]) 

(defun here-tooltip (text)
  (require 'tooltip)
  (require 'avoid)
  (let* ((P (mouse-avoidance-point-position))
	 (frame (car P))
	 (x (cadr P))
	 (y (cddr P))
	 (oP (mouse-position))
	 (oframe (car oP))
	 (ox     (cadr oP))
	 (oy     (cddr oP)))
    (set-mouse-position frame x y)
    (tooltip-show text)
    (set-mouse-position frame (1+ x) y)))

(defun here-tooltip (text)
  (message text))

(defun message-with-bouncing (text)
  (let* ((width (- (window-width (minibuffer-window))
		   (+ 1 (length "[<] ") (length " [>]"))))
	 (tl (length text))
	 (steps (- tl width))
	 j
	 (flag t))
  (if (< tl width)
      (message "%s" (eyecatch-put-text-color text))
    (while flag
      (dotimes (i steps)
	(message "%s" (format "[<] %s [ ]" 
			      (eyecatch-put-text-color (substring text i (+ i width)))))
	(unless (setq flag (sit-for (if (eq i 0) 
					eyecatch-border-internval
				      eyecatch-default-internval)))
	  (return)))
      (if flag
	  (dotimes (i steps)
	    (setq j (- steps i))
	    (message "%s"
		     (format "[ ] %s [>]" 
			     (eyecatch-put-text-color
			      (substring text j (+ j width)))))
	    (unless (setq flag (sit-for (if (eq i 0) 
					eyecatch-border-internval
				      eyecatch-default-internval)))
	      (return))
	    ))
      (garbage-collect)
      ))))

(defun message-with-rolling (text)
  (setq text (concat "  <Message>: " text "            "))
  (let* ((width (- (window-width (minibuffer-window))
		   (+ 1 (length "[<] "))))
	 (tl (length text))
	 (normal-range (- tl width))
	 j
	 (flag t))
  (if (< tl width)
      (here-tooltip (format "%s" text))
    (while flag
      (dotimes (i tl)
	(if (< i normal-range)
	    (message "%s" (format "[<] %s" 
				  (eyecatch-put-text-color (substring text i (+ i width)))))
	  (message "%s" (format "[<] %s" 
				(eyecatch-put-text-color (concat (substring text i) 
								 (substring text 0 (- (+ i width) tl)))))))
	(unless (setq flag (sit-for (if (eq i 0) 
					eyecatch-border-internval
					eyecatch-default-internval)))
	  (return)))
      (garbage-collect)
      ))))

(defun eyecatch-put-text-color (text)
  (let ((cl (length eyecatch-faces))
	c)
    (dotimes (i (length text))
      (setq c (aref eyecatch-faces (mod i cl)))
      (put-text-property i (1+ i) 'face c text)))
  text)

;;(message-with-bouncing "!@#$%^&*()ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789") 

(message-with-bouncing
 (concat "GNU, which stands for Gnu's Not Unix, is the name for the complete "
	 "Unix-compatible software system which I am writing so that I can give it "
	 "away free to everyone who can use it.(1) Several other volunteers are "
	 "helping me.  Contributions of time, money, programs and equipment are "
	 "greatly needed. "))

(message-with-rolling
 (concat "Changes in Emacs 25.4: (1) New C interpreter written in emacs lisp is introduced. "
	 " (2) Edebug can debug compiled C code directly."
	 " (3) Accelerator pedal and brake pedal are supported as modifier keys(A-x and B-x in short)."))