cgit.sxemacs.org Git - packages/blob - xemacs-packages/footnote/footnote.el

   1 ;;; footnote.el --- Footnote support for message mode
   2
   3 ;; Copyright (C) 1997 by Free Software Foundation, Inc.
   4
   5 ;; Author: Steven L Baur <steve@xemacs.org>
   6 ;; Keywords: mail, news
   7 ;; Version: 0.20
   8
   9 ;; This file is part of XEmacs.
  10
  11 ;; XEmacs is free software; you can redistribute it and/or modify it
  12 ;; under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; XEmacs is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  24 ;; 02111-1307, USA.
  25
  26 ;;; Synched up with: Not in FSF
  27
  28 ;;; Commentary:
  29
  30 ;; This file provides footnote[1] support for message-mode in emacsen.
  31 ;; footnote-mode is implemented as a minor mode.
  32
  33 ;; [1] Footnotes look something like this.  Along with some decorative
  34 ;; stuff.
  35
  36 ;; TODO:
  37 ;; Reasonable Undo support.
  38 ;; more language styles.
  39
  40 ;;; Change Log before introduction of the separate ChangeLog file:
  41
  42 ;; Apr-04-1997: Added option to narrow buffer when editing the text of
  43 ;;              a footnote.
  44 ;;              Insertion and renumbering now works.
  45 ;;              Deletion and renumbering now works.
  46 ;;              Footnote styles implemented.
  47 ;; Apr-05-1997: Added dumb version of footnote-set-style.
  48 ;;              Merged minor corrections from Hrvoje Niksic, Sudish Joseph,
  49 ;;              and David Moore.
  50 ;;              Remove absolute dependency on message-mode.
  51 ;;              Replicate letters when footnote numbers hit the end of
  52 ;;              the alphabet.
  53 ;; Apr-06-1997: Emacs portability patches from Lars Magne Ingebrigtsen.
  54 ;; Apr-18-1997: Stricter matching of footnote tag.  (Idea from Colin Rafferty)
  55 ;; May-16-1997: Allow customization of spacing of footnote body tag.  (Idea
  56 ;;              from Samuel Tardieu).
  57
  58 ;;; Code:
  59
  60 (require 'cl)
  61
  62 (defgroup footnote nil
  63   "Support for footnotes in mail and news messages."
  64   :group 'message)
  65
  66 ;;;###autoload
  67 (defcustom footnote-mode-line-string " FN"
  68   "*String to display in modes section of the mode-line."
  69   :group 'footnote)
  70
  71 (defcustom footnote-mode-hook nil
  72   "*Hook functions run when footnote-mode is activated."
  73   :type 'hook
  74   :group 'footnote)
  75
  76 (defcustom footnote-narrow-to-footnotes-when-editing nil
  77   "*If set, narrow to footnote text body while editing a footnote."
  78   :type 'boolean
  79   :group 'footnote)
  80
  81 (defcustom footnote-prompt-before-deletion t
  82   "*If set, prompt before deleting a footnote.
  83 There is currently no way to undo deletions."
  84   :type 'boolean
  85   :group 'footnote)
  86
  87 (defcustom footnote-spaced-footnotes t
  88   "If set true it will put a blank line between each footnote.
  89 If nil, no blank line will be inserted."
  90   :type 'boolean
  91   :group 'footnote)
  92
  93 (defcustom footnote-always-blank-line-before-signature t
  94   "If set true, a blank line will always be inserted before signature.
  95 This has visible effect only when `footnote-spaced-footnotes' is not true."
  96   :type 'boolean
  97   :group 'footnote)
  98
  99 (defcustom footnote-style 'numeric
 100   "*Style used for footnoting.
 101 numeric == 1, 2, 3, ...
 102 numeric-latin == {¹, ², ³} | {1, 2, 3, 4, ...}
 103 english-lower == a, b, c, ...
 104 english-upper == A, B, C, ...
 105 roman-lower == i, ii, iii, iv, v, ...
 106 roman-upper == I, II, III, IV, V, ...
 107 Some versions of XEmacs and Emacs/mule may support further styles
 108 like 'hebrew, 'greek-lower, and 'greek-upper."
 109   :type 'symbol
 110   :group 'footnote)
 111
 112 (defcustom footnote-use-message-mode t
 113   "*If non-nil assume Footnoting will be done in message-mode."
 114   :type 'boolean
 115   :group 'footnote)
 116
 117 (defcustom footnote-body-tag-spacing 2
 118   "*Number of blanks separating a footnote body tag and its text."
 119   :type 'integer
 120   :group 'footnote)
 121
 122 ;;;###autoload
 123 (defvar footnote-prefix [(control ?c) ?!]
 124   "*When not using message mode, the prefix to bind in `mode-specific-map'")
 125
 126 ;;; Interface variables that probably shouldn't be changed
 127
 128 ;; FIXME!  Make this customize-able?
 129 (defvar footnote-section-tag "Footnotes: "
 130   "*Tag inserted at beginning of footnote section.")
 131
 132 (defvar footnote-section-tag-regexp footnote-section-tag
 133   "*Regexp which indicates the start of a footnote section.")
 134
 135 ;; FIXME!  Make these customize-able?
 136 (defvar footnote-start-tag "["
 137   "*String used to denote start of numbered footnote.")
 138
 139 (defvar footnote-end-tag "]"
 140   "*String used to denote end of numbered footnote.")
 141
 142 (defvar footnote-signature-separator (if (boundp 'message-signature-separator)
 143                                          message-signature-separator
 144                                        "^-- $")
 145   "*String used to recognize .signatures.")
 146
 147 ;;; Private variables
 148
 149 (defvar footnote-text-marker-alist nil
 150   "List of markers pointing to text of footnotes in message buffer.")
 151 (make-variable-buffer-local 'footnote-text-marker-alist)
 152
 153 (defvar footnote-pointer-marker-alist nil
 154   "List of markers pointing to footnote pointers in message buffer.")
 155 (make-variable-buffer-local 'footnote-pointer-marker-alist)
 156
 157 (defvar footnote-mouse-highlight 'highlight
 158   "Text property name to enable mouse over highlight.")
 159
 160 (defvar footnote-mode nil
 161   "Variable indicating whether footnote minor mode is active.")
 162 (make-variable-buffer-local 'footnote-mode)
 163
 164 (defvar footnote-style-is-really-numeric-latin nil
 165   "Whether current numeric style is actually numeric-latin.")
 166 (make-variable-buffer-local 'footnote-style-is-really-numeric-latin)
 167
 168 ;;; Default styles
 169 ;;; NUMERIC-LATIN
 170 (defconst footnote-numeric-latin-regexp "[¹²³]"
 171   "Regexp for Latin superscript digits.")
 172
 173 (defun Footnote-numeric-latin (n)
 174   "Numeric-latin footnote style.
 175 Use latin superscript digits if no more than three footnotes."
 176   (case n
 177     (1 "¹")
 178     (2 "²")
 179     (3 "³")
 180     (t (error "This should never happen."))))
 181
 182 ;;; NUMERIC
 183 (defconst footnote-numeric-regexp "[0-9]"
 184   "Regexp for digits.")
 185
 186 (defun Footnote-numeric (n)
 187   "Numeric footnote style.
 188 Use Arabic numerals for footnoting."
 189   (int-to-string n))
 190
 191 ;;; ENGLISH UPPER
 192 (defconst footnote-english-upper "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 193   "Upper case English alphabet.")
 194
 195 (defconst footnote-english-upper-regexp "[A-Z]"
 196   "Regexp for upper case English alphabet.")
 197
 198 (defun Footnote-english-upper (n)
 199   "Upper case English footnoting.
 200 Wrapping around the alphabet implies successive repetitions of letters."
 201   (let* ((ltr (mod (1- n) (length footnote-english-upper)))
 202          (rep (/ (1- n) (length footnote-english-upper)))
 203          (chr (char-to-string (aref footnote-english-upper ltr)))
 204          rc)
 205     (while (>= rep 0)
 206       (setq rc (concat rc chr))
 207       (setq rep (1- rep)))
 208     rc))
 209
 210 ;;; ENGLISH LOWER
 211 (defconst footnote-english-lower "abcdefghijklmnopqrstuvwxyz"
 212   "Lower case English alphabet.")
 213
 214 (defconst footnote-english-lower-regexp "[a-z]"
 215   "Regexp of lower case English alphabet.")
 216
 217 (defun Footnote-english-lower (n)
 218   "Lower case English footnoting.
 219 Wrapping around the alphabet implies successive repetitions of letters."
 220   (let* ((ltr (mod (1- n) (length footnote-english-lower)))
 221          (rep (/ (1- n) (length footnote-english-lower)))
 222          (chr (char-to-string (aref footnote-english-lower ltr)))
 223          rc)
 224     (while (>= rep 0)
 225       (setq rc (concat rc chr))
 226       (setq rep (1- rep)))
 227     rc))
 228
 229 ;;; ROMAN LOWER
 230 (defconst footnote-roman-lower-list
 231   '((1 . "i") (5 . "v") (10 . "x")
 232     (50 . "l") (100 . "c") (500 . "d") (1000 . "m"))
 233   "List of roman numerals with their values.")
 234
 235 (defconst footnote-roman-lower-regexp "[ivxlcdm]"
 236   "Regexp of roman numerals.")
 237
 238 (defun Footnote-roman-lower (n)
 239   "Generic Roman number footnoting."
 240   (Footnote-roman-common n footnote-roman-lower-list))
 241
 242 ;;; ROMAN UPPER
 243 (defconst footnote-roman-upper-list
 244   '((1 . "I") (5 . "V") (10 . "X")
 245     (50 . "L") (100 . "C") (500 . "D") (1000 . "M"))
 246   "List of roman numerals with their values.")
 247
 248 (defconst footnote-roman-upper-regexp "[IVXLCDM]"
 249   "Regexp of roman numerals.  Not complete")
 250
 251 (defun Footnote-roman-upper (n)
 252   "Generic Roman number footnoting."
 253   (Footnote-roman-common n footnote-roman-upper-list))
 254
 255 (defun Footnote-roman-common (n footnote-roman-list)
 256   "Lower case Roman footnoting."
 257   (let* ((our-list footnote-roman-list)
 258          (rom-lngth (length our-list))
 259          (rom-high 0)
 260          (rom-low 0)
 261          (rom-div -1)
 262          (count-high 0)
 263          (count-low 0))
 264     ;; find surrounding numbers
 265     (while (and (<= count-high (1- rom-lngth))
 266                 (>= n (car (nth count-high our-list))))
 267       ;; (message "Checking %d" (car (nth count-high our-list)))
 268       (setq count-high (1+ count-high)))
 269     (setq rom-high count-high)
 270     (setq rom-low (1- count-high))
 271     ;; find the appropriate divisor (if it exists)
 272     (while (and (= rom-div -1)
 273                 (< count-low rom-high))
 274       (when (or (> n (- (car (nth rom-high our-list))
 275                         (/ (car (nth count-low our-list))
 276                            2)))
 277                 (= n (- (car (nth rom-high our-list))
 278                         (car (nth count-low our-list)))))
 279         (setq rom-div count-low))
 280       ;; (message "Checking %d and %d in div loop" rom-high count-low)
 281       (setq count-low (1+ count-low)))
 282     ;;(message "We now have high: %d, low: %d, div: %d, n: %d"
 283     ;;         rom-high rom-low (if rom-div rom-div -1) n)
 284     (let ((rom-low-pair (nth rom-low our-list))
 285           (rom-high-pair (nth rom-high our-list))
 286           (rom-div-pair (if (not (= rom-div -1)) (nth rom-div our-list) nil)))
 287       ;; (message "pairs are: rom-low: %S, rom-high: %S, rom-div: %S"
 288       ;;          rom-low-pair rom-high-pair rom-div-pair)
 289       (cond
 290        ((< n 0) (error "Footnote-roman-common called with n < 0"))
 291        ((= n 0) "")
 292        ((= n (car rom-low-pair)) (cdr rom-low-pair))
 293        ((= n (car rom-high-pair)) (cdr rom-high-pair))
 294        ((= (car rom-low-pair) (car rom-high-pair))
 295         (concat (cdr rom-low-pair)
 296                 (Footnote-roman-common
 297                  (- n (car rom-low-pair))
 298                  footnote-roman-list)))
 299        ((>= rom-div 0) (concat (cdr rom-div-pair) (cdr rom-high-pair)
 300                                (Footnote-roman-common
 301                                 (- n (- (car rom-high-pair)
 302                                         (car rom-div-pair)))
 303                                 footnote-roman-list)))
 304        (t (concat (cdr rom-low-pair)
 305                   (Footnote-roman-common
 306                    (- n (car rom-low-pair))
 307                    footnote-roman-list)))))))
 308
 309 ;;; list of all footnote styles
 310 (defvar footnote-style-alist
 311   `((numeric       Footnote-numeric       ,footnote-numeric-regexp)
 312     (numeric-latin Footnote-numeric-latin ,footnote-numeric-latin-regexp
 313                    ""                     "")
 314     (english-lower Footnote-english-lower ,footnote-english-lower-regexp)
 315     (english-upper Footnote-english-upper ,footnote-english-upper-regexp)
 316     (roman-lower   Footnote-roman-lower   ,footnote-roman-lower-regexp)
 317     (roman-upper   Footnote-roman-upper   ,footnote-roman-upper-regexp))
 318   "Styles of footnote tags available.
 319 By default only boring Arabic numbers, latin superscript numbers, English
 320 letters and Roman Numerals are available.
 321 See footnote-han.el, footnote-greek.el and footnote-hebrew.el for more
 322 exciting styles.")
 323
 324 ;;; Style utilities & functions
 325
 326 (defun* Footnote-start-tag (&optional (style footnote-style))
 327   (or (fourth (assq style footnote-style-alist))
 328                   footnote-start-tag))
 329
 330 (defun* Footnote-end-tag (&optional (style footnote-style))
 331   (or (fifth (assq style footnote-style-alist))
 332       footnote-end-tag))
 333
 334 (defun Footnote-style-p (style)
 335   "Return non-nil if style is a valid style known to footnote-mode."
 336   (assq style footnote-style-alist))
 337
 338 (defun Footnote-index-to-string (index)
 339   "Convert a binary index into a string to display as a footnote.
 340 Conversion is done based upon the current selected style."
 341   (let ((alist (if (Footnote-style-p footnote-style)
 342                    (assq footnote-style footnote-style-alist)
 343                  (first footnote-style-alist))))
 344     (funcall (second alist) index)))
 345
 346 (defun Footnote-current-regexp ()
 347   "Return the regexp of the index of the current style."
 348   (concat (third (or (assq footnote-style footnote-style-alist)
 349                      (first footnote-style-alist))) "+"))
 350
 351 (defun* Footnote-refresh-footnotes (&optional (old-style
 352                                                (assq footnote-style
 353                                                      footnote-style-alist)))
 354   "Redraw all footnotes.
 355 The old footnotes are assumed to be of OLD-STYLE and the style they will
 356 be redrawn is the current one.  You must call this or arrange to have this
 357 called after changing footnote styles."
 358   (let ((old-ind-regexp (third old-style))
 359         (old-start-tag  (Footnote-start-tag (first old-style)))
 360         (old-end-tag    (Footnote-end-tag (first old-style)))
 361         (new-start-tag  (Footnote-start-tag))
 362         (new-end-tag    (Footnote-end-tag)))
 363     (save-excursion
 364       ;; Take care of the pointers first
 365       (loop for i from 1
 366             for footnote-entry in footnote-pointer-marker-alist
 367             do (loop for location in (cdr footnote-entry)
 368                      do
 369                      (setf (point) location)
 370                      (search-backward-regexp (concat (regexp-quote old-start-tag)
 371                                                      old-ind-regexp)
 372                                              nil t)
 373                      (when (looking-at (concat
 374                                         (regexp-quote old-start-tag)
 375                                         "\\(" old-ind-regexp "+\\)"
 376                                         (regexp-quote old-end-tag)))
 377                        (replace-match (concat
 378                                        new-start-tag
 379                                        (Footnote-index-to-string i)
 380                                        new-end-tag)
 381                                       nil "\\1"))))
 382
 383       ;; Now take care of the text section
 384       (loop for i from 1
 385             for footnote-entry in footnote-text-marker-alist
 386             do (setf (point) (cdr footnote-entry))
 387                (when (looking-at (concat
 388                                   (regexp-quote old-start-tag)
 389                                   "\\(" old-ind-regexp "+\\)"
 390                                   (regexp-quote old-end-tag)))
 391                  (replace-match (concat
 392                                  new-start-tag
 393                                  (Footnote-index-to-string i)
 394                                  new-end-tag)
 395                                 nil "\\1"))))))
 396
 397 (defun Footnote-assoc-index (key alist)
 398   "Give index of key in alist."
 399   (position key alist :key #'first))
 400
 401 (defun Footnote-switch-style (to)
 402   "Switch to another footnote style TO, refreshing the footnotes."
 403   (let ((old (assq footnote-style footnote-style-alist))
 404         (to  (if (and (eq footnote-style 'numeric)
 405                       (eq to 'numeric-latin)
 406                       footnote-style-is-really-numeric-latin)
 407                  (or (car (first (rest (member* 'numeric-latin
 408                                                 footnote-style-alist :key #'car))))
 409                      (car (first footnote-style-alist)))
 410                to)))
 411     (cond ((and (eq to 'numeric-latin)
 412                 (>= (length footnote-text-marker-alist) 4))
 413            (message "You won't see latin superscripts until you have less than four footnotes.")
 414            (Footnote-set-style 'numeric)
 415            (setq footnote-style-is-really-numeric-latin t))
 416           (t (Footnote-set-style to)))
 417     (Footnote-refresh-footnotes old)))
 418
 419 (defun* Footnote-cycle-style (&optional (arg 1))
 420   "Select ARG'th (from the current one) defined footnote style."
 421   (interactive "p")
 422   (Footnote-switch-style
 423    (first (nth (mod (+ (Footnote-assoc-index footnote-style
 424                                              footnote-style-alist)
 425                        arg)
 426                     (length footnote-style-alist))
 427                footnote-style-alist))))
 428
 429 (defun Footnote-set-style (&optional style)
 430   "Select a specific style."
 431   (interactive
 432    (list (intern (completing-read
 433                   "Footnote Style: "
 434                   obarray #'Footnote-style-p 'require-match))))
 435   (setq footnote-style-is-really-numeric-latin nil)
 436   (setq footnote-style style))
 437
 438 ;; Internal functions
 439 (defun Footnote-insert-numbered-footnote (arg &optional mousable)
 440   "Insert numbered footnote at (point)."
 441   (let* ((start (point))
 442          (end (progn
 443                 (insert-before-markers (concat (Footnote-start-tag)
 444                                                (Footnote-index-to-string arg)
 445                                                (Footnote-end-tag)))
 446                 (point))))
 447
 448     (add-text-properties start end
 449                          (list 'footnote-number arg 'start-open t))
 450     (when mousable
 451       (add-text-properties start end
 452                            (list footnote-mouse-highlight t)))))
 453
 454 (defun Footnote-renumber (from to pointer-alist text-alist)
 455   "Renumber a single footnote."
 456   (let* ((posn-list (cdr pointer-alist)))
 457     (setcar pointer-alist to)
 458     (setcar text-alist to)
 459     (while posn-list
 460       (goto-char (car posn-list))
 461       (search-backward (Footnote-start-tag) nil t)
 462       (when (looking-at (format "%s%s%s"
 463                                 (regexp-quote (Footnote-start-tag))
 464                                 (Footnote-current-regexp)
 465                                 (regexp-quote (Footnote-end-tag))))
 466         (add-text-properties (match-beginning 0) (match-end 0)
 467                              (list 'footnote-number to))
 468         (replace-match (format "%s%s%s"
 469                                (Footnote-start-tag)
 470                                (Footnote-index-to-string to)
 471                                (Footnote-end-tag))))
 472       (setq posn-list (cdr posn-list)))
 473     (goto-char (cdr text-alist))
 474     (when (looking-at (format "%s%s%s"
 475                               (regexp-quote (Footnote-start-tag))
 476                               (Footnote-current-regexp)
 477                               (regexp-quote (Footnote-end-tag))))
 478       (add-text-properties (match-beginning 0) (match-end 0)
 479                            (list 'footnote-number to))
 480       (replace-match (format "%s%s%s"
 481                              (Footnote-start-tag)
 482                              (Footnote-index-to-string to)
 483                              (Footnote-end-tag)) nil t))))
 484
 485 ;; Not needed?
 486 (defun Footnote-narrow-to-footnotes ()
 487   "Restrict text in buffer to show only text of footnotes."
 488   (interactive) ; testing
 489   (goto-char (point-max))
 490   (when (re-search-backward footnote-signature-separator nil t)
 491     (let ((end (point)))
 492       (when (re-search-backward (concat "^" footnote-section-tag-regexp) nil t)
 493         (narrow-to-region (point) end)))))
 494
 495 (defun Footnote-goto-char-point-max ()
 496   "Move to end of buffer or prior to start of .signature."
 497   (goto-char (point-max))
 498   (or (re-search-backward footnote-signature-separator nil t)
 499       (point)))
 500
 501 (defun Footnote-insert-text-marker (arg locn)
 502   "Insert a marker pointing to footnote arg, at buffer location locn."
 503   (let ((marker (make-marker)))
 504     (unless (assq arg footnote-text-marker-alist)
 505       (set-marker marker locn)
 506       (setq footnote-text-marker-alist
 507             (acons arg marker footnote-text-marker-alist))
 508       (setq footnote-text-marker-alist
 509             (Footnote-sort footnote-text-marker-alist)))))
 510
 511 (defun Footnote-insert-pointer-marker (arg locn)
 512   "Insert a marker pointing to footnote arg, at buffer location locn."
 513   (let ((marker (make-marker))
 514         alist)
 515     (set-marker marker locn)
 516     (if (setq alist (assq arg footnote-pointer-marker-alist))
 517         (setf alist
 518               (cons marker (cdr alist)))
 519       (setq footnote-pointer-marker-alist
 520             (acons arg (list marker) footnote-pointer-marker-alist))
 521       (setq footnote-pointer-marker-alist
 522             (Footnote-sort footnote-pointer-marker-alist)))))
 523
 524 (defun Footnote-insert-footnote (arg)
 525   "Insert a footnote numbered arg, at (point)."
 526   (push-mark)
 527   (Footnote-insert-pointer-marker arg (point))
 528   (Footnote-insert-numbered-footnote arg t)
 529   (Footnote-goto-char-point-max)
 530   (let (insertion-before-signature)
 531     (if (re-search-backward (concat "^" footnote-section-tag-regexp) nil t)
 532         (save-restriction
 533           (when footnote-narrow-to-footnotes-when-editing
 534             (Footnote-narrow-to-footnotes))
 535           (Footnote-goto-footnote (1- arg)) ; evil, FIXME (less evil now)
 536           (or (= arg 1)
 537               (when (re-search-forward (if footnote-spaced-footnotes
 538                                            "\n\n"
 539                                          (concat "\n"
 540                                                  (regexp-quote (Footnote-start-tag))
 541                                                  (Footnote-current-regexp)
 542                                                  (regexp-quote (Footnote-end-tag))))
 543                                        nil t)
 544                 (beginning-of-line)
 545                 t)
 546               (progn (Footnote-goto-char-point-max)
 547                      (when (and (setq insertion-before-signature
 548                                       (looking-at footnote-signature-separator))
 549                                 (not footnote-spaced-footnotes)
 550                                 footnote-always-blank-line-before-signature)
 551                        (forward-line -1)
 552                        (when (looking-at "^$")
 553                          (delete-char 1))))))
 554       ;; Need to create footnote section.
 555       (setq insertion-before-signature (looking-at footnote-signature-separator))
 556       (unless (looking-at "^$")
 557         (insert "\n"))
 558       (when (eobp)
 559         (insert "\n"))
 560       (insert footnote-section-tag "\n"))
 561     (let ((old-point (point)))
 562       (Footnote-insert-numbered-footnote arg nil)
 563       (Footnote-insert-text-marker arg old-point))
 564     insertion-before-signature))
 565
 566 (defun Footnote-sort (list)
 567   (sort list (lambda (e1 e2)
 568                (< (car e1) (car e2)))))
 569
 570 (defun Footnote-text-under-cursor ()
 571   "Return the number of footnote if in footnote text.
 572 Nil is returned if the cursor is not positioned over the text of
 573 a footnote."
 574   (when (and (let ((old-point (point)))
 575                (save-excursion
 576                  (save-restriction
 577                    (Footnote-narrow-to-footnotes)
 578                    (and (>= old-point (point-min))
 579                         (<= old-point (point-max))))))
 580              (>= (point) (cdar footnote-text-marker-alist)))
 581     (let ((i 1)
 582           alist-txt rc)
 583       (while (and (setq alist-txt (nth i footnote-text-marker-alist))
 584                   (null rc))
 585         (when (< (point) (cdr alist-txt))
 586           (setq rc (car (nth (1- i) footnote-text-marker-alist))))
 587         (setq i (1+ i)))
 588       (when (and (null rc)
 589                  (null alist-txt))
 590         (setq rc (car (nth (1- i) footnote-text-marker-alist))))
 591       rc)))
 592
 593 (defun Footnote-under-cursor ()
 594   "Return the number of the footnote underneath the cursor.
 595 Nil is returned if the cursor is not over a footnote."
 596   (or (get-text-property (point) 'footnote-number)
 597       (Footnote-text-under-cursor)))
 598
 599 ;;; User functions
 600
 601 (defun Footnote-make-hole ()
 602   (save-excursion
 603     (let ((i 0)
 604           (notes (length footnote-pointer-marker-alist))
 605           alist-ptr alist-txt rc)
 606       (while (< i notes)
 607         (setq alist-ptr (nth i footnote-pointer-marker-alist))
 608         (setq alist-txt (nth i footnote-text-marker-alist))
 609         (when (< (point) (- (cadr alist-ptr) 3))
 610           (unless rc
 611             (setq rc (car alist-ptr)))
 612           (save-excursion
 613             (message "Renumbering from %s to %s"
 614                      (Footnote-index-to-string (car alist-ptr))
 615                      (Footnote-index-to-string
 616                       (1+ (car alist-ptr))))
 617             (Footnote-renumber (car alist-ptr)
 618                                (1+ (car alist-ptr))
 619                                alist-ptr
 620                                alist-txt)))
 621         (setq i (1+ i)))
 622       rc)))
 623
 624 ;;;###autoload
 625 (defun Footnote-add-footnote (&optional arg)
 626   "Add a numbered footnote.
 627 The number the footnote receives is dependent upon the relative location
 628 of any other previously existing footnotes.
 629 If the variable `footnote-narrow-to-footnotes-when-editing' is set,
 630 the buffer is narrowed to the footnote body.  The restriction is removed
 631 by using `Footnote-back-to-message'."
 632   (interactive "*P")
 633   (when (and (eq footnote-style 'numeric-latin)
 634              (= 3 (length footnote-text-marker-alist)))
 635     (Footnote-switch-style 'numeric)
 636     (setq footnote-style-is-really-numeric-latin t))
 637   (let ((num (if footnote-text-marker-alist
 638                  (if (< (point) (cadar (last footnote-pointer-marker-alist)))
 639                      (Footnote-make-hole)
 640                    (1+ (caar (last footnote-text-marker-alist))))
 641                1)))
 642     (message "Adding footnote %d" num)
 643     (let ((insertion-before-signature (Footnote-insert-footnote num)))
 644       (insert-before-markers (make-string footnote-body-tag-spacing ? ))
 645       (let ((opoint (point)))
 646         (save-excursion
 647           (insert-before-markers
 648            (if (or footnote-spaced-footnotes
 649                    (and footnote-always-blank-line-before-signature
 650                         insertion-before-signature))
 651                "\n\n"
 652              "\n"))
 653           (when footnote-narrow-to-footnotes-when-editing
 654             (Footnote-narrow-to-footnotes)))
 655         ;; Emacs/XEmacs bug?  save-excursion doesn't restore point when using
 656         ;; insert-before-markers.
 657         (goto-char opoint)))))
 658
 659 (defun Footnote-delete-footnote (&optional arg)
 660   "Delete a numbered footnote.
 661 With no parameter, delete the footnote under (point).  With arg specified,
 662 delete the footnote with that number."
 663   (interactive "*P")
 664   (let ((arg (or arg (Footnote-under-cursor))))
 665     (when (and arg
 666                (or (not footnote-prompt-before-deletion)
 667                    (y-or-n-p (format "Really delete footnote %d?" arg))))
 668       (let* ((alist-ptr      (assq arg footnote-pointer-marker-alist))
 669              (alist-at-entry (member* arg footnote-text-marker-alist :key #'car))
 670              (alist-txt      (first alist-at-entry)))
 671         (unless (and alist-ptr alist-txt)
 672           (error "Can't delete footnote %d" arg))
 673         (loop for location in (cdr alist-ptr)
 674               do (save-excursion
 675                    (setf (point) location)
 676                    (kill-region (search-backward-regexp
 677                                  (concat (regexp-quote (Footnote-start-tag))
 678                                          (Footnote-current-regexp))
 679                                  nil t)
 680                                 location)))
 681         (save-excursion
 682           (if (rest alist-at-entry)
 683               (Footnote-goto-footnote (1+ arg))
 684             (Footnote-goto-char-point-max)
 685             (unless (or (looking-at "^$")
 686                         footnote-spaced-footnotes
 687                         footnote-always-blank-line-before-signature))
 688             (when (and (not (looking-at "^$"))
 689                        (not footnote-spaced-footnotes)
 690                        footnote-always-blank-line-before-signature)
 691               (forward-line -1)))
 692           (kill-region (cdr alist-txt)
 693                        (point)))
 694         (setq footnote-pointer-marker-alist
 695               (delq alist-ptr footnote-pointer-marker-alist))
 696         (setq footnote-text-marker-alist
 697               (delq alist-txt footnote-text-marker-alist))
 698         (Footnote-renumber-footnotes)
 699         (when (and footnote-style-is-really-numeric-latin
 700                    (eq footnote-style 'numeric)
 701                    (< (length footnote-text-marker-alist) 4))
 702           (Footnote-switch-style 'numeric-latin))
 703         (when (and (null footnote-text-marker-alist)
 704                    (null footnote-pointer-marker-alist))
 705           (save-excursion
 706             (let ((end   (Footnote-goto-char-point-max))
 707                   (start (1- (re-search-backward
 708                               (concat "^" footnote-section-tag-regexp)
 709                               nil t))))
 710               (forward-line -1)
 711               (let ((end (- end (cond ((looking-at "\n")
 712                                        (kill-line)
 713                                        1)
 714                                       (t 0)))))
 715                 (kill-region start (if (< end (point-max))
 716                                        end
 717                                      (point-max)))))))))))
 718
 719 (defun Footnote-renumber-footnotes (&optional arg)
 720   "Renumber footnotes, starting from 1."
 721   (interactive "*P")
 722   (save-excursion
 723     (let ((i 0)
 724           (notes (length footnote-pointer-marker-alist))
 725           alist-ptr alist-txt)
 726       (while (< i notes)
 727         (setq alist-ptr (nth i footnote-pointer-marker-alist))
 728         (setq alist-txt (nth i footnote-text-marker-alist))
 729         (unless (eq (1+ i) (car alist-ptr))
 730           (Footnote-renumber (car alist-ptr) (1+ i) alist-ptr alist-txt))
 731         (setq i (1+ i))))))
 732
 733 (defun Footnote-goto-footnote (&optional arg)
 734   "Jump to the text of a footnote.
 735 With no parameter, jump to the text of the footnote under (point).  With arg
 736 specified, jump to the text of that footnote."
 737   (interactive "P")
 738   (setq zmacs-region-stays t)
 739   (let (footnote)
 740     (if arg
 741         (setq footnote (assq arg footnote-text-marker-alist))
 742       (when (setq arg (Footnote-under-cursor))
 743         (setq footnote (assq arg footnote-text-marker-alist))))
 744     (if footnote
 745         (goto-char (cdr footnote))
 746       (if (eq arg 0)
 747           (progn
 748             (goto-char (point-max))
 749             (re-search-backward (concat "^" footnote-section-tag-regexp))
 750             (forward-line 1))
 751         (error "I don't see a footnote here.")))))
 752
 753 (defun Footnote-back-to-message (&optional arg)
 754   "Move cursor back to footnote referent.
 755 If the cursor is not over the text of a footnote, point is not changed.
 756 If the buffer was narrowed due to `footnote-narrow-to-footnotes-when-editing'
 757 being set it is automatically widened."
 758   (interactive "P")
 759   (setq zmacs-region-stays t)
 760   (let ((note (Footnote-text-under-cursor)))
 761     (when note
 762       (when footnote-narrow-to-footnotes-when-editing
 763         (widen))
 764       (goto-char (cadr (assq note footnote-pointer-marker-alist))))))
 765
 766 ;;;###autoload
 767 (defvar footnote-mode-map nil
 768   "Keymap used for footnote minor mode.")
 769
 770 ;; Set up our keys
 771 ;;;###autoload
 772 (unless footnote-mode-map
 773   (setq footnote-mode-map (make-sparse-keymap))
 774   (define-key footnote-mode-map "a" 'Footnote-add-footnote)
 775   (define-key footnote-mode-map "b" 'Footnote-back-to-message)
 776   (define-key footnote-mode-map "c" 'Footnote-cycle-style)
 777   (define-key footnote-mode-map "d" 'Footnote-delete-footnote)
 778   (define-key footnote-mode-map "g" 'Footnote-goto-footnote)
 779   (define-key footnote-mode-map "r" 'Footnote-renumber-footnotes)
 780   (define-key footnote-mode-map "s" 'Footnote-set-style))
 781
 782 ;;;###autoload
 783 (defvar footnote-minor-mode-map nil
 784   "Keymap used for binding footnote minor mode.")
 785
 786 ;;;###autoload
 787 (unless footnote-minor-mode-map
 788   (define-key global-map footnote-prefix footnote-mode-map))
 789
 790 ;;;###autoload
 791 (if (progn (condition-case () (require 'easymenu) (error nil))
 792            (fboundp 'easy-menu-add-item))
 793     (easy-menu-add-item nil '("Cmds")
 794                         '("Footnotes"
 795                           ["Add Footnote" Footnote-add-footnote t]
 796                           ["Delete Footnote" Footnote-delete-footnote t]
 797                           ["Goto Footnote" Footnote-goto-footnote t]
 798                           ["Back to Message" Footnote-back-to-message t]
 799                           ["Renumber Footnotes" Footnote-renumber-footnotes t]
 800                           "--"
 801                           ["Set Footnote Style" Footnote-set-style t]
 802                           ["Cycle Footnote Style" Footnote-cycle-style t]
 803                           )))
 804
 805
 806 ;;;###autoload
 807 (defun footnote-mode (&optional arg)
 808   "Toggle footnote minor mode.
 809 \\<message-mode-map>
 810 key             binding
 811 ---             -------
 812
 813 \\[Footnote-set-style]                  Footnote-set-style
 814 \\[Footnote-renumber-footnotes]         Footnote-renumber-footnotes
 815 \\[Footnote-goto-footnote]              Footnote-goto-footnote
 816 \\[Footnote-delete-footnote]            Footnote-delete-footnote
 817 \\[Footnote-cycle-style]                Footnote-cycle-style
 818 \\[Footnote-back-to-message]            Footnote-back-to-message
 819 \\[Footnote-add-footnote]               Footnote-add-footnote
 820
 821 "
 822   (interactive "*P")
 823   ;; (filladapt-mode t)
 824   (setq zmacs-region-stays t)
 825   (setq footnote-mode
 826         (if (null arg) (not footnote-mode)
 827           (> (prefix-numeric-value arg) 0)))
 828   (when footnote-mode
 829     ;; (Footnote-setup-keybindings)
 830     (make-local-variable 'footnote-style)
 831     (if (fboundp 'force-mode-line-update)
 832         (force-mode-line-update)
 833       (set-buffer-modified-p (buffer-modified-p)))
 834
 835     (when (boundp 'filladapt-token-table)
 836       ;; add tokens to filladapt to match footnotes
 837       ;; 1] xxxxxxxxxxx x x x or [1] x x x x x x x
 838       ;;    xxx x xx xxx xxxx        x x x xxxxxxxxxx
 839       (let ((bullet-regexp (concat (regexp-quote (Footnote-start-tag))
 840                                    "?[0-9a-zA-Z]+"
 841                                    (regexp-quote (Footnote-end-tag))
 842                                    "[ \t]")))
 843         (unless (assoc bullet-regexp filladapt-token-table)
 844           (setq filladapt-token-table
 845                 (append filladapt-token-table
 846                         (list (list bullet-regexp 'bullet)))))))
 847
 848     (run-hooks 'footnote-mode-hook)))
 849
 850 ;; install on minor-mode-alist
 851 ;;;###autoload
 852 (when (fboundp 'add-minor-mode)
 853     ;; XEmacs
 854     (add-minor-mode 'footnote-mode
 855                     footnote-mode-line-string
 856                     footnote-minor-mode-map))
 857
 858 ;; Emacs -- don't autoload
 859 (unless (assq 'footnote-mode minor-mode-alist)
 860   (setq minor-mode-alist
 861         (cons '(footnote-mode footnote-mode-line-string)
 862               minor-mode-alist)))
 863
 864 (provide 'footnote)
 865
 866 ;;; footnote.el ends here