cgit.sxemacs.org Git - packages/blob - xemacs-packages/x-symbol/lisp/x-symbol-nomule.el

   1 ;;; x-symbol-nomule.el --- XEmacs/no-Mule support for package x-symbol
   2
   3 ;; Copyright (C) 1996-1998, 2002 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Christoph Wedler <wedler@users.sourceforge.net>
   6 ;; Maintainer: (Please use `M-x x-symbol-package-bug' to contact the maintainer)
   7 ;; Version: 4.5
   8 ;; Keywords: WYSIWYG, LaTeX, HTML, wp, math, internationalization
   9 ;; X-URL: http://x-symbol.sourceforge.net/
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it 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 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20 ;;
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program; if not, write to the Free Software
  23 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; If you want to use package x-symbol, please visit the URL (use
  28 ;; \\[x-symbol-package-web]) and read the info (use \\[x-symbol-package-info]).
  29
  30 ;;; Code:
  31
  32 (when (featurep 'mule)
  33   (error "This file is meant to be used with XEmacs/no-Mule"))
  34 (provide 'x-symbol-nomule)
  35 (require 'x-symbol-hooks)
  36 (eval-when-compile (require 'x-symbol)) ; x-symbol also requires this file
  37 ;;(eval-when-compile
  38 ;;  (defvar x-symbol-encode-rchars)
  39 ;;  (defvar x-symbol-face-docstrings))
  40
  41
  42 ;;;===========================================================================
  43 ;;;  Function aliases and internal variables
  44 ;;;===========================================================================
  45
  46 (defalias 'x-symbol-make-cset 'x-symbol-nomule-make-cset)
  47 (defalias 'x-symbol-make-char 'x-symbol-nomule-make-char)
  48 (defalias 'x-symbol-init-charsym-syntax 'ignore)
  49 (defalias 'x-symbol-charsym-after 'x-symbol-nomule-charsym-after)
  50 (defalias 'x-symbol-string-to-charsyms 'x-symbol-nomule-string-to-charsyms)
  51 (defalias 'x-symbol-match-before 'x-symbol-nomule-match-before)
  52 (defalias 'x-symbol-encode-lisp 'x-symbol-nomule-encode-lisp)
  53 (defalias 'x-symbol-pre-command-hook 'x-symbol-nomule-pre-command-hook)
  54 (defalias 'x-symbol-post-command-hook 'x-symbol-nomule-post-command-hook)
  55 (defalias 'x-symbol-encode-charsym-after 'x-symbol-nomule-encode-charsym-after)
  56 (defalias 'x-symbol-init-quail-bindings 'ignore)
  57
  58 (defun-when-void put-display-table (range value display-table)
  59   "Set the value for char RANGE to VALUE in DISPLAY-TABLE.  "
  60   (if (sequencep display-table)
  61       (aset display-table range value)
  62     (put-char-table range value display-table)))
  63
  64 (defun-when-void get-display-table (character display-table)
  65   "Find value for CHARACTER in DISPLAY-TABLE.  "
  66   (if (sequencep display-table)
  67       (aref display-table character)
  68     (get-char-table character display-table)))
  69
  70 (defvar x-symbol-nomule-mouse-yank-function
  71   (and (boundp 'mouse-yank-function)
  72        mouse-yank-function)
  73   "Function that is called upon by `x-symbol-nomule-mouse-yank-function'.")
  74
  75 (defvar x-symbol-nomule-mouse-track-function
  76   (and (boundp 'default-mouse-track-normalize-point-function)
  77        default-mouse-track-normalize-point-function)
  78   "Function that is called upon by `x-symbol-nomule-mouse-track-function'.")
  79
  80 (defvar x-symbol-nomule-cstring-regexp "[\231-\237][\041-\176\240-\377]"
  81   "Internal configuration.  Regexp matching cstrings of length 2.
  82 You should probably change the value when adding additional csets.")
  83 ;; should match `x-symbol-nomule-multibyte-char-p'.
  84
  85 (defvar x-symbol-nomule-char-table nil
  86   "Internal.  Map characters to charsyms.")
  87 (defvar x-symbol-nomule-pre-command nil
  88   "Internal.  Used for pre- and post-command handling.")
  89
  90 (defvar x-symbol-nomule-leading-faces-alist nil
  91   "Internal.  Alist of leading character with their faces.
  92 Each element looks like (LEADING NORMAL SUBSCRIPT SUPERSCRIPT).")
  93 (defvar x-symbol-nomule-font-lock-face nil
  94   "Internal.  Face to fontify current font-lock match.")
  95
  96 (defvar x-symbol-nomule-display-table
  97   (let ((table (make-display-table))
  98         (i 128))
  99     (while (< i 160)
 100       (put-display-table i "" table)
 101       (incf i))
 102     table)
 103   "Display table in faces with non-standard charset registry.
 104 It makes the leading characters, range \\200-\\237, invisible.")
 105
 106 (defvar x-symbol-nomule-character-quote-syntax "\\" ; bug in XEmacs
 107   "Syntax designator for leading characters in cstrings.")
 108
 109
 110 ;;;===========================================================================
 111 ;;;  Init code
 112 ;;;===========================================================================
 113
 114 (defun x-symbol-nomule-init-faces (fonts prefix &optional display-table)
 115   "Create and return faces for FONTS.
 116 If a font can not be found, return nil for that font.  PREFIX is the
 117 prefix in the name of the new face.  If non-nil, the new faces use
 118 display table DISPLAY-TABLE."
 119   (let ((suffixes '("-face" "-sub-face" "-sup-face"))
 120         (docstrings x-symbol-face-docstrings)
 121         (raise 0)
 122         faces font face)
 123     (while suffixes
 124       (push (when (setq font (x-symbol-try-font-name (car fonts) raise))
 125               (setq face (intern (concat prefix (car suffixes))))
 126               (make-face face (car docstrings))
 127               (set-face-font face font)
 128               (if display-table (set-face-display-table face display-table))
 129               face)
 130             faces)
 131       (setq fonts (cdr fonts)
 132             suffixes (cdr suffixes)
 133             raise (1+ raise)
 134             docstrings (cdr docstrings)))
 135     (nreverse faces)))
 136
 137 (defun x-symbol-nomule-make-cset (cset fonts)
 138   "Define new charsets according to CSET using FONTS.
 139 See `x-symbol-init-cset'.  Return (NORMAL SUBSCRIPT SUPERSCIPT).  Each
 140 element is a face or nil if the corresponding font in FONTS could not be
 141 found.  Return nil, if no default font for that registry could be found."
 142   (cond ((noninteractive) (list nil))
 143         ((eq (x-symbol-cset-coding cset) x-symbol-default-coding)
 144          (or (x-symbol-nomule-init-faces fonts "x-symbol") ; no registry!
 145              (list nil)))
 146         ((x-symbol-try-font-name (car fonts))
 147          (let* ((faces (x-symbol-nomule-init-faces
 148                         fonts
 149                         (concat "x-symbol-" (x-symbol-cset-registry cset))
 150                         x-symbol-nomule-display-table))
 151                 (leading (x-symbol-cset-leading cset))
 152                 (ass (assq leading x-symbol-nomule-leading-faces-alist)))
 153            (if x-symbol-nomule-character-quote-syntax
 154                (modify-syntax-entry leading
 155                                     x-symbol-nomule-character-quote-syntax
 156                                     (standard-syntax-table)))
 157            (if ass
 158                (setcdr ass faces)
 159              (push (cons leading faces)
 160                    x-symbol-nomule-leading-faces-alist))
 161            faces))))
 162
 163 (defun x-symbol-nomule-make-char (cset encoding charsym face coding)
 164   "Define character in CSET with ENCODING, represented by CHARSYM.
 165 The character is considered to be a 8bit character in CODING.  Use FACE
 166 when character is presented in the grid or has a non-standard registry."
 167   (unless (char-table-p x-symbol-nomule-char-table)
 168     (setq x-symbol-nomule-char-table (make-char-table 'generic))
 169     (put-char-table t nil x-symbol-nomule-char-table))
 170   (let* ((leading (and (null (eq coding
 171                                  (or x-symbol-default-coding 'iso-8859-1)))
 172                        (cadar cset)))
 173          (table (if leading
 174                     (get-char-table leading x-symbol-nomule-char-table)
 175                   x-symbol-nomule-char-table))
 176          (cstring (if leading
 177                       (concat (list leading encoding))
 178                     (char-to-string (int-to-char encoding)))))
 179     (unless (char-table-p table)
 180       (setq table (make-char-table 'generic))
 181       (put-char-table t nil table)
 182       (put-char-table leading table x-symbol-nomule-char-table))
 183     (put-char-table encoding charsym table)
 184     (x-symbol-set-cstrings charsym coding cstring
 185                            (and coding (>= encoding 160) (int-to-char encoding))
 186                            face)))
 187
 188
 189 ;;;===========================================================================
 190 ;;;  Character recognition
 191 ;;;===========================================================================
 192
 193 (defun x-symbol-nomule-multibyte-char-p (leading octet)
 194   "Non-nil if LEADING and OCTET are a multibyte character."
 195   (and leading (>= leading ?\200) (< leading ?\240)
 196        octet (or (< octet ?\177) (>= octet ?\240)) (>= octet ?\41)))
 197
 198 (defun x-symbol-nomule-encode-charsym-after ()
 199   (let ((charsym (get-char-table (char-after) x-symbol-nomule-char-table)))
 200     (if (char-table-p charsym)
 201         (let ((after (char-after (1+ (point)))))
 202           (if after
 203               (progn (setq x-symbol-encode-rchars 2)
 204                      (get-char-table after charsym))
 205             (setq x-symbol-encode-rchars 1)
 206             nil))
 207       (setq x-symbol-encode-rchars 1)
 208       charsym)))
 209
 210 (defun x-symbol-nomule-charsym-after (&optional pos)
 211   "Return x-symbol charsym for character at POS.
 212 POS defaults to point.  If POS is out of range, return nil.  Otherwise,
 213 return (POS1 . CHARSYM) where POS1 is POS-1 if the character before POS
 214 is a leading character and POS1 is POS otherwise.  CHARSYM is the
 215 x-symbol charsym for the character at POS1 or nil otherwise."
 216   (or pos (setq pos (point)))
 217   (let ((before (char-before pos))
 218         (after (char-after pos)))
 219     (and after
 220          (if (or (x-symbol-nomule-multibyte-char-p before after)
 221                  (x-symbol-nomule-multibyte-char-p
 222                   (setq before after)
 223                   (setq after (char-after (incf pos)))))
 224              (let ((table (get-char-table before x-symbol-nomule-char-table)))
 225                (cons (1- pos)
 226                      (and (char-table-p table) (get-char-table after table))))
 227            (cons (1- pos)
 228                  (and (symbolp (setq after (get-char-table
 229                                             before
 230                                             x-symbol-nomule-char-table)))
 231                       after))))))
 232
 233 (defun x-symbol-nomule-string-to-charsyms (string)
 234   "Return list of charsyms for the characters in STRING.
 235 If a character is not represented as a charsym, use the character itself
 236 if is an ascii in the range \\040-\\176, otherwise nil."
 237   (let ((chars (nreverse (append string nil)))
 238         result after table)
 239     (while chars
 240       (setq after (pop chars))
 241       (push (if (x-symbol-nomule-multibyte-char-p (car chars) after)
 242                 (and (setq table (get-char-table (pop chars)
 243                                                  x-symbol-nomule-char-table))
 244                      (get-char-table after table))
 245               (or (get-char-table after x-symbol-nomule-char-table) after))
 246             result))
 247     result))
 248
 249 (defun x-symbol-nomule-match-before (atree pos &optional case-fn)
 250   "Return association in ATREE for longest match before POS.
 251 Return (START . VALUE) where the buffer substring between START and
 252 point is the key to the association VALUE in ATREE.  Do not use matches
 253 where the character before START is a leading character.  If optional
 254 CASE-FN is non-nil, convert characters before the current position with
 255 CASE-FN.  See `x-symbol-atree-push'."
 256   (or pos (setq pos (point)))
 257   (let ((result nil)
 258         char)
 259     (while (setq char (if case-fn
 260                           (funcall case-fn (char-after (decf pos)))
 261                         (char-after (decf pos)))
 262                  atree (cdr (assoc char (cdr atree))))
 263       (and (car atree)
 264            (not (x-symbol-nomule-multibyte-char-p (char-before pos) char))
 265            (setq result (cons pos (car atree)))))
 266     result))
 267
 268
 269 ;;;===========================================================================
 270 ;;;  Point correction
 271 ;;;===========================================================================
 272
 273 ;; `mouse-track', `mouse-yank': If you set `mouse-yank-function' and/or
 274 ;; `default-mouse-track-normalize-point-function', set them before initializing
 275 ;; package X-Symbol.
 276 (and x-symbol-nomule-mouse-yank-function
 277      (setq mouse-yank-function 'x-symbol-nomule-mouse-yank-function))
 278 (and x-symbol-nomule-mouse-track-function
 279      (setq default-mouse-track-normalize-point-function
 280            'x-symbol-nomule-mouse-track-function))
 281
 282 (defun x-symbol-nomule-goto-leading-char ()
 283   "If character before point is a leading character, move point left."
 284   (if (x-symbol-nomule-multibyte-char-p (char-before (point))
 285                                         (char-after (point)))
 286       (backward-char)))
 287
 288 (defun x-symbol-nomule-mouse-yank-function ()
 289   "Function used as value for `mouse-yank'.
 290 If character under point is a x-symbol character, move point to its
 291 leading character before calling `x-symbol-nomule-mouse-yank-function'."
 292   (x-symbol-nomule-goto-leading-char)
 293   (funcall x-symbol-nomule-mouse-yank-function))
 294
 295 (defun x-symbol-nomule-mouse-track-function (type forwardp)
 296   ;; checkdoc-params: (type forwardp)
 297   "Function used as value for `default-mouse-track-normalize-point-function'.
 298 After calling `x-symbol-nomule-mouse-track-function', if character under
 299 point is a x-symbol character, move point to its leading character."
 300   (funcall x-symbol-nomule-mouse-track-function type forwardp)
 301   (x-symbol-nomule-goto-leading-char))
 302
 303
 304 ;;;===========================================================================
 305 ;;;  Command hooks
 306 ;;;===========================================================================
 307
 308 ;; Functions in these hooks are run twice (and more) when pressing a key which
 309 ;; runs a keyboard macro, e.g., if [backspace] runs [delete] and [delete] runs
 310 ;; `delete-backward-char'.
 311
 312 (defun x-symbol-nomule-pre-command-hook ()
 313   "Function used in `pre-command-hook' when `x-symbol-mode' is turned on.
 314 Hide revealed characters, see `x-symbol-hide-revealed-at-point'.
 315 Provide input method TOKEN, see `x-symbol-token-input'.  If character
 316 under point is a x-symbol character, move point to its leading character."
 317   (x-symbol-hide-revealed-at-point)
 318   (when (and x-symbol-mode (null x-symbol-nomule-pre-command))
 319     (setq x-symbol-nomule-pre-command
 320           (if (x-symbol-nomule-multibyte-char-p (char-before (point))
 321                                                 (char-after (point)))
 322               (prog1 (point) (backward-char))
 323             t))
 324     (x-symbol-token-input)))
 325
 326 (defun x-symbol-nomule-post-command-hook ()
 327   "Function used in `post-command-hook' when `x-symbol-mode' is turned on.
 328 Provide input method ELECTRIC, see `x-symbol-electric-input'.  Start
 329 idle timer for info in echo area and revealing invisible characters, see
 330 `x-symbol-start-itimer-once'.  Make sure that not only a part of a
 331 length-two cstring has been deleted by the previous command."
 332   (when (and x-symbol-nomule-pre-command x-symbol-mode)
 333     (if (stringp (car-safe (car-safe buffer-undo-list)))
 334         ;; i.e., after deleting text (`delete-char',...)
 335         (let* ((pos (abs (cdar buffer-undo-list)))
 336                (str (caar buffer-undo-list))
 337                (len (length str))
 338                (pre (and (> len 0)
 339                          (x-symbol-nomule-multibyte-char-p
 340                           (char-before (point)) (aref str 0))))
 341                (post (and (> len 0)
 342                           (x-symbol-nomule-multibyte-char-p
 343                            (aref str (1- len)) (char-after pos)))))
 344           (if (or pre post)
 345               (delete-region (if pre (1- pos) pos) (if post (1+ pos) pos))))
 346       (and (null (car-safe buffer-undo-list))
 347            (integerp x-symbol-nomule-pre-command)
 348            (= (point) x-symbol-nomule-pre-command)
 349            ;; i.e., after pressing Right
 350            (< x-symbol-nomule-pre-command (point-max))
 351            (goto-char (1+ x-symbol-nomule-pre-command))))
 352     (x-symbol-electric-input)
 353     (if (x-symbol-nomule-multibyte-char-p (char-after (point))
 354                                           (char-after (1+ (point))))
 355         (forward-char))
 356     (x-symbol-start-itimer-once))
 357   (setq x-symbol-nomule-pre-command nil))
 358
 359
 360 ;;;===========================================================================
 361 ;;;  Font-lock support
 362 ;;;===========================================================================
 363
 364 (defun x-symbol-nomule-match-cstring (limit)
 365   "Match next cstring of length 2 before LIMIT if `x-symbol-mode' is on.
 366 Sets `x-symbol-nomule-font-lock-face' to the face used for this cstring
 367 considering super- and subscripts."
 368   (when x-symbol-mode
 369     (let (faces old)
 370       (block nil
 371         (while (re-search-forward x-symbol-nomule-cstring-regexp limit t)
 372           (setq faces (cdr (assq (char-after (match-beginning 0))
 373                                  x-symbol-nomule-leading-faces-alist))
 374                 old (get-text-property (match-beginning 0) 'face))
 375           (or (listp old) (setq old (list old)))
 376           (if (setq x-symbol-nomule-font-lock-face
 377                     (or (and (memq 'x-symbol-sup-face old) (caddr faces))
 378                         (and (memq 'x-symbol-sub-face old) (cadr faces))
 379                         (car faces)))
 380               (return t)))))))
 381
 382 (defun x-symbol-nomule-fontify-cstrings ()
 383   "Fontify all cstrings in buffer even when `x-symbol-mode' is off.
 384 Faces according to the cstrings are prepended to existing face settings.
 385 See also `x-symbol-nomule-match-cstring'."
 386   (let ((x-symbol-mode t)
 387         (limit (point-max)))
 388     (goto-char (point-min))
 389     (while (x-symbol-nomule-match-cstring limit)
 390       (font-lock-prepend-text-property (match-beginning 0) (match-end 0)
 391                                        'face
 392                                        x-symbol-nomule-font-lock-face))))
 393
 394 ;;; Local IspellPersDict: .ispell_xsymb
 395 ;;; x-symbol-nomule.el ends here