emacs/nxhtml/util/sml-modeline.el

   1 ;;; sml-modeline.el --- Show position in a scrollbar like way in mode-line
   2 ;;
   3 ;; Author: Lennart Borgman (lennart O borgman A gmail O com)
   4 ;; Created: 2010-03-16 Tue
   5 ;; Version: 0.5
   6 ;; Last-Updated: 2010-03-18 Thu
   7 ;; URL: http://bazaar.launchpad.net/~nxhtml/nxhtml/main/annotate/head%3A/util/sml-modeline.el
   8 ;; Keywords:
   9 ;; Compatibility:
  10 ;;
  11 ;; Features that might be required by this library:
  12 ;;
  13 ;;   None
  14 ;;
  15 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16 ;;
  17 ;;; Commentary:
  18 ;;
  19 ;; Show scrollbar like position indicator in mode line.
  20 ;; See the global minor mode `sml-modeline-mode' for more information.
  21 ;;
  22 ;; Idea and part of this code is adapted from David Engster's and Drew
  23 ;; Adam's code in these mail messages:
  24 ;;
  25 ;;   http://lists.gnu.org/archive/html/emacs-devel/2010-03/msg00523.html
  26 ;;   http://permalink.gmane.org/gmane.emacs.devel/122038
  27 ;;
  28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29 ;;
  30 ;;; Change log:
  31 ;;
  32 ;;
  33 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  34 ;;
  35 ;; This program is free software; you can redistribute it and/or
  36 ;; modify it under the terms of the GNU General Public License as
  37 ;; published by the Free Software Foundation; either version 3, or
  38 ;; (at your option) any later version.
  39 ;;
  40 ;; This program is distributed in the hope that it will be useful,
  41 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  42 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  43 ;; General Public License for more details.
  44 ;;
  45 ;; You should have received a copy of the GNU General Public License
  46 ;; along with this program; see the file COPYING.  If not, write to
  47 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
  48 ;; Floor, Boston, MA 02110-1301, USA.
  49 ;;
  50 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  51 ;;
  52 ;;; Code:
  53
  54 ;;;###autoload
  55 (defgroup sml-modeline nil
  56   "Customization group for `sml-modeline-mode'."
  57   :group 'frames)
  58
  59 (defun sml-modeline-refresh ()
  60   "Refresh after option changes if loaded."
  61   (when (featurep 'sml-modeline)
  62     (when (and (boundp 'sml-modeline-mode)
  63                sml-modeline-mode)
  64       (sml-modeline-mode -1)
  65       (sml-modeline-mode 1))))
  66
  67 (defcustom sml-modeline-len 12
  68   "Mode line indicator total length."
  69   :type 'integer
  70   :set (lambda (sym val)
  71          (set-default sym val)
  72          (sml-modeline-refresh))
  73   :group 'sml-modeline)
  74
  75 (defcustom sml-modeline-borders nil
  76   "Indicator borders.
  77 This is a pair of indicators, like [] or nil."
  78   :type '(choice (const :tag "None" nil)
  79                  (cons (string :tag "Left border")
  80                        (string :tag "Right border")))
  81   :set (lambda (sym val)
  82          (set-default sym val)
  83          (sml-modeline-refresh))
  84   :group 'sml-modeline)
  85
  86 (defcustom sml-modeline-numbers 'percentage
  87   "Position number style.
  88 This can be 'percentage or 'line-number."
  89   :type '(choice (const :tag "Line numbers" line-numbers)
  90                  (const :tag "Percentage" percentage))
  91   :set (lambda (sym val)
  92          (set-default sym val)
  93          (sml-modeline-refresh))
  94   :group 'sml-modeline)
  95
  96 (defface sml-modeline-end-face
  97   '((t (:inherit match)))
  98   "Face for invisible buffer parts."
  99   :group 'sml-modeline)
 100 ;; 'face `(:background ,(face-foreground 'mode-line-inactive)
 101 ;;         :foreground ,(face-background 'mode-line))
 102
 103 (defface sml-modeline-vis-face
 104   '((t (:inherit region)))
 105   "Face for invisible buffer parts."
 106   :group 'sml-modeline)
 107 ;; 'face `(:background ,(face-foreground 'mode-line)
 108 ;;         :foreground ,(face-background 'mode-line))
 109
 110 ;;(sml-modeline-create)
 111 (defun sml-modeline-create ()
 112  (let* ((wstart (window-start))
 113         (wend (window-end))
 114         number-max number-beg number-end
 115         (sml-begin (or (car sml-modeline-borders) ""))
 116         (sml-end   (or (cdr sml-modeline-borders) ""))
 117         (inner-len (- sml-modeline-len (length sml-begin) (length sml-end)))
 118         bpad-len epad-len
 119         pos-%
 120         start end
 121         string)
 122    (if (not (or (< wend (save-restriction (widen) (point-max)))
 123                 (> wstart 1)))
 124        ""
 125      (cond
 126       ((eq sml-modeline-numbers 'percentage)
 127        (setq number-max (save-restriction (widen) (point-max)))
 128        (setq number-beg (/ (float wstart) (float number-max)))
 129        (setq number-end (/ (float wend) (float number-max)))
 130        (setq start (floor (* number-beg inner-len)))
 131        (setq end (floor (* number-end inner-len)))
 132        (setq string
 133              (concat (format "%02d" (round (* number-beg 100)))
 134                      "-"
 135                      (format "%02d" (round (* number-end 100))) "%%")))
 136       ((eq sml-modeline-numbers 'line-numbers)
 137        (save-restriction
 138          (widen)
 139          (setq number-max (line-number-at-pos (point-max)))
 140          (setq number-beg (line-number-at-pos wstart))
 141          (setq number-end (line-number-at-pos wend)))
 142        (setq start (floor (* (/ number-beg (float number-max)) inner-len)))
 143        (setq end   (floor (* (/ number-end (float number-max)) inner-len)))
 144        (setq string
 145              (concat "L"
 146                      (format "%02d" number-beg)
 147                      "-"
 148                      (format "%02d" number-end))))
 149       (t (error "Unknown sml-modeline-numbers=%S" sml-modeline-numbers)))
 150      (setq inner-len (max inner-len (length string)))
 151      (setq bpad-len (floor (/ (- inner-len (length string)) 2.0)))
 152      (setq epad-len (- inner-len (length string) bpad-len))
 153      (setq pos-% (+ bpad-len (length string) -1))
 154      (setq string (concat sml-begin
 155                           (make-string bpad-len 32)
 156                           string
 157                           (make-string epad-len 32)
 158                           sml-end))
 159      ;;(assert (= (length string) sml-modeline-len) t)
 160      (when (= start sml-modeline-len) (setq start (1- start)))
 161      (setq start (+ start (length sml-begin)))
 162      (when (= start end) (setq end (1+ end)))
 163      (when (= end pos-%) (setq end (1+ end))) ;; If on % add 1
 164      (put-text-property start end 'face 'sml-modeline-vis-face string)
 165      (when (and (= 0 (length sml-begin))
 166                 (= 0 (length sml-end)))
 167        (put-text-property 0 start 'face 'sml-modeline-end-face string)
 168        (put-text-property end sml-modeline-len 'face 'sml-modeline-end-face string))
 169      string)))
 170
 171 (defvar sml-modeline-old-car-mode-line-position nil)
 172
 173 ;;;###autoload
 174 (define-minor-mode sml-modeline-mode
 175   "Show buffer size and position like scrollbar in mode line.
 176 You can customize this minor mode, see option `sml-modeline-mode'.
 177
 178 Note: If you turn this mode on then you probably want to turn off
 179 option `scroll-bar-mode'."
 180   :global t
 181   :group 'sml-modeline
 182   (if sml-modeline-mode
 183       (progn
 184         (unless sml-modeline-old-car-mode-line-position
 185           (setq sml-modeline-old-car-mode-line-position (car mode-line-position)))
 186         (setcar mode-line-position '(:eval (list (sml-modeline-create)))))
 187     (setcar mode-line-position sml-modeline-old-car-mode-line-position)))
 188
 189
 190 (provide 'sml-modeline)
 191 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 192 ;;; sml-modeline.el ends here