egg-cnv.el

   1 ;;; egg-cnv.el --- Conversion Backend in Egg Input Method Architecture
   2
   3 ;; Copyright (C) 1997, 1998 Mule Project,
   4 ;; Powered by Electrotechnical Laboratory, JAPAN.
   5 ;; Project Leader: Satoru Tomura <tomura@etl.go.jp>
   6
   7 ;; Author: NIIBE Yutaka <gniibe@mri.co.jp>
   8 ;;         KATAYAMA Yoshio <kate@pfu.co.jp>
   9 ;; Maintainer: NIIBE Yutaka <gniibe@mri.co.jp>
  10 ;; Keywords: mule, multilingual, input method
  11
  12 ;; This file will be part of GNU Emacs (in future).
  13
  14 ;; EGG is free software; you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either version 2, or (at your option)
  17 ;; any later version.
  18
  19 ;; EGG is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  27 ;; Boston, MA 02111-1307, USA.
  28
  29 ;;; Commentary:
  30
  31
  32 ;;; Code:
  33
  34 (defsubst egg-bunsetsu-info () 'intangible)
  35
  36 (defun egg-get-bunsetsu-info (p)
  37   (let ((info (get-text-property p (egg-bunsetsu-info))))
  38     (cond
  39      ((consp info)
  40       (setq egg-conversion-backend (car info))
  41       (cdr info)))))
  42 ;;
  43
  44 (defvar egg-conversion-backend-alist nil)
  45 (make-variable-buffer-local 'egg-conversion-backend-alist)
  46 (defvar egg-conversion-backend nil)
  47 (make-variable-buffer-local 'egg-conversion-backend)
  48
  49 (defvar egg-finalize-backend-alist nil)
  50
  51 (defun egg-set-current-backend (language)
  52   (let ((backend (assoc lang  egg-conversion-backend-alist)))
  53     (if (null backend)
  54         (error "%S is not supported" lang)
  55       (setq egg-conversion-backend (cdr backend)))))
  56
  57 (defun egg-initialize-backend (language)
  58   (egg-set-current-backend language)
  59   (funcall (aref egg-conversion-backend 0)))
  60
  61 (defun egg-start-conversion (yomi-string language)
  62   (egg-set-current-backend language)
  63   (funcall (aref egg-conversion-backend 1) yomi-string language))
  64 (defun egg-get-bunsetsu-converted (bunsetsu-info)
  65   (funcall (aref egg-conversion-backend 2) bunsetsu-info))
  66 (defun egg-get-bunsetsu-source (bunsetsu-info)
  67   (funcall (aref egg-conversion-backend 3) bunsetsu-info))
  68 (defun egg-list-candidates (bunsetsu-info prev-bunsetsu-info)
  69   (funcall (aref egg-conversion-backend 4) bunsetsu-info prev-bunsetsu-info))
  70 (defun egg-get-number-of-candidates (bunsetsu-info)
  71   (funcall (aref egg-conversion-backend 5) bunsetsu-info))
  72 (defun egg-get-current-candidate-number (bunsetsu-info)
  73   (funcall (aref egg-conversion-backend 6) bunsetsu-info))
  74 (defun egg-get-all-candidates (bunsetsu-info)
  75   (funcall (aref egg-conversion-backend 7) bunsetsu-info))
  76 (defun egg-decide-candidate (bunsetsu-info candidate-pos)
  77   (funcall (aref egg-conversion-backend 8) bunsetsu-info candidate-pos))
  78 (defun egg-change-bunsetsu-length (b0 b1 b2 len)
  79   (funcall (aref egg-conversion-backend 9) b0 b1 b2 len))
  80 (defun egg-end-conversion (bunsetsu-info-list)
  81   (funcall (aref egg-conversion-backend 10) bunsetsu-info-list))
  82
  83 (defun egg-finalize-backend ()
  84   (let ((alist egg-finalize-backend-alist))
  85     (while alist
  86       (funcall (car (car (car alist))) (cdr (car (car alist))))
  87       (setq alist (cdr alist)))))
  88
  89 (defmacro egg-set-conversion-backend-internal (backend langs &optional force)
  90   `(let ((l ,langs) pair)
  91      (while l
  92        (setq pair (assoc (car l) egg-conversion-backend-alist))
  93        (if (null pair)
  94            (setq egg-conversion-backend-alist
  95                  (cons (cons (car l) ,backend)
  96                        egg-conversion-backend-alist))
  97          ,(if force `(setcdr pair ,backend)))
  98        (setq pair (cons (aref ,backend 11) (car l)))
  99        (if (null (assoc pair egg-finalize-backend-alist))
 100            (setq egg-finalize-backend-alist
 101                  (cons (list pair) egg-finalize-backend-alist)))
 102        (setq l (cdr l)))))
 103
 104 (defun egg-set-conversion-backend (backend curent-langs other-langs)
 105   (egg-set-conversion-backend-internal backend curent-langs t)
 106   (egg-set-conversion-backend-internal backend other-langs))
 107 \f
 108 (defvar egg-conversion-open "|")
 109 (defvar egg-conversion-close "|")
 110 (defvar egg-conversion-separator " ")
 111
 112 ;;
 113 (defun egg-convert-region (start end)
 114   (interactive "r")
 115   (let (bunsetsu-info-list lang contin p s e)
 116     (save-restriction
 117       (narrow-to-region start end)
 118       (goto-char start)
 119       (insert egg-conversion-open)
 120       (add-text-properties start (point)
 121                            (list
 122                             'egg-start t
 123                             'egg-source (buffer-substring (point)
 124                                                           (point-max))))
 125       (if egg-conversion-face
 126           (put-text-property start (point) 'invisible t))
 127       (setq start (point))
 128       (egg-separate-languages start (point-max))
 129       (goto-char start)
 130       (while (< (point) (point-max))
 131         (setq lang (get-text-property (point) 'egg-lang)
 132               s (point)
 133               e (point))
 134         (while (and (< e (point-max))
 135                     (equal lang (get-text-property e 'egg-lang)))
 136           (setq e (next-single-property-change e 'egg-lang nil (point-max))))
 137         (setq bunsetsu-info-list
 138               (egg-start-conversion (buffer-substring s e) lang))
 139         (setq contin (< e (point-max)))
 140         (delete-region s e)
 141         (egg-insert-bunsetsu-list bunsetsu-info-list
 142                                   (if (< (point) (point-max)) 'contine t))))
 143     (setq p (point))
 144     (insert egg-conversion-close)
 145     (put-text-property p (point) 'egg-end t)
 146     (if egg-conversion-face
 147         (put-text-property p (point) 'invisible t))
 148     (goto-char start)))
 149
 150 (defun egg-separate-languages (start end)
 151   (let (lang last-lang last-chinese p l c cset)
 152     ;; 1st pass -- mark undefined Chinese part
 153     (goto-char start)
 154     (while (< (point) end)
 155       (setq p (next-single-property-change (point) 'its-lang nil end))
 156       (cond
 157        ((get-text-property (point) 'its-lang)
 158         (goto-char p))
 159        ((setq l (egg-chinese-syllable (buffer-substring (point) p)))
 160         (setq p (point))
 161         (goto-char (+ (point) l))
 162         (put-text-property p (point) 'its-lang "Chinese"))
 163        ((progn
 164           (setq c (following-char)
 165                 cset (char-charset c))
 166           (eq cset 'chinese-sisheng))
 167         (setq p (point))
 168         (forward-char)
 169         (put-text-property p (point) 'its-lang "Chinese"))
 170        ((eq cset 'ascii)
 171         (forward-char))
 172        (t
 173         (setq p (point))
 174         (forward-char)
 175         (put-text-property p (point) 'its-lang (egg-char-to-language c)))))
 176     ;; 2nd pass -- set language property
 177     (goto-char start)
 178     (while (< (point) end)
 179       (setq lang (get-text-property (point) 'its-lang))
 180       (cond
 181        ((null lang)
 182         (setq lang (or last-lang
 183                        (egg-next-part-lang end))))
 184        ((equal lang "Chinese")
 185         (setq lang (or last-chinese
 186                        (egg-next-chinese-lang end)))))
 187       (setq last-lang lang)
 188       (if (or (equal lang "Chinese-GB") (equal lang "Chinese-CNS"))
 189           (setq last-chinese lang))
 190       (setq p (point))
 191       (goto-char (next-single-property-change (point) 'its-lang nil end))
 192       (set-text-properties p (point) (list 'egg-lang lang)))))
 193
 194 (defun egg-char-to-language (c)
 195   (let ((charset (char-charset c))
 196         (list language-info-alist))
 197     (while (and list
 198                 (null (memq charset (assq 'charset (car list)))))
 199       (setq list (cdr list)))
 200     (car (car list))))
 201
 202 (defun egg-next-part-lang (end)
 203   (let* ((p (next-single-property-change (point) 'its-lang nil end))
 204          (lang (get-text-property p 'its-lang)))
 205     (if (equal lang "Chinese")
 206         (egg-next-chinese-lang end)
 207       (or lang
 208           its-current-language
 209           egg-default-language))))
 210
 211 (defun egg-next-chinese-lang (end)
 212   (let (p lang)
 213     (setq p (point))
 214     (while (and (< p end) (null lang))
 215       (setq p (next-single-property-change p 'its-lang nil end))
 216       (setq lang (get-text-property p 'its-lang))
 217       (if (null (or (equal lang "Chinese-GB")
 218                     (equal lang "Chinese-CNS")))
 219           (setq lang nil)))
 220     (cond
 221      (lang lang)
 222      ((or (equal its-current-language "Chinese-GB")
 223           (equal its-current-language "Chinese-CNS"))
 224       its-current-language)
 225      ((or (equal egg-default-language "Chinese-GB")
 226           (equal egg-default-language "Chinese-CNS"))
 227       egg-default-language)
 228      (t "Chinese-GB"))))
 229 \f
 230 (defvar egg-conversion-face nil)
 231 (defvar egg-conversion-map
 232   (let ((map (make-sparse-keymap))
 233         (i 33))
 234     (while (< i 127)
 235       (define-key map (vector i) 'egg-exit-conversion-unread-char)
 236       (setq i (1+ i)))
 237     (define-key map "\C-@" 'egg-decide-first-char)
 238     (define-key map [?\C-\ ] 'egg-decide-first-char)
 239     (define-key map "\C-a"   'egg-beginning-of-conversion-buffer)
 240     (define-key map "\C-b"   'egg-backward-bunsetsu)
 241     (define-key map "\C-c"   'egg-abort-conversion)
 242     (define-key map "\C-e"   'egg-end-of-conversion-buffer)
 243     (define-key map "\C-f"   'egg-forward-bunsetsu)
 244     (define-key map "\C-h"   'egg-help-command)
 245     (define-key map "\C-i"   'egg-shrink-bunsetsu)
 246     (define-key map "\C-k"   'egg-decide-before-point)
 247 ;;    (define-key map "\C-l"   'egg-exit-conversion)  ; Don't override C-L
 248     (define-key map "\C-m"   'egg-exit-conversion)
 249     (define-key map "\C-n"   'egg-next-candidate)
 250     (define-key map "\C-o"   'egg-enlarge-bunsetsu)
 251     (define-key map "\C-p"   'egg-previous-candidate)
 252     (define-key map "\M-s"   'egg-select-candidate)
 253     (define-key map [return] 'egg-exit-conversion)
 254 ;;    (define-key map "\C-\\"  'egg-exit-mode-no-egg)
 255     (define-key map [right]  'egg-forward-bunsetsu)
 256     (define-key map [left]   'egg-backward-bunsetsu)
 257     (define-key map " "      'egg-next-candidate)
 258     (define-key map "/"      'egg-exit-conversion)
 259     map)
 260   "Keymap for EGG Conversion mode.")
 261
 262 (defun egg-exit-conversion-unread-char ()
 263   (interactive)
 264   (setq unread-command-events (list last-command-event))
 265   (egg-exit-conversion))
 266
 267 (defun egg-insert-bunsetsu (bunsetsu-info last)
 268   (let ((bunsetsu (egg-get-bunsetsu-converted bunsetsu-info))
 269         (p (point)))
 270     (insert bunsetsu)
 271     (if (null (eq last t))
 272         (insert egg-conversion-separator))
 273     (add-text-properties p (point)
 274                          (list 'face      egg-conversion-face
 275                                'local-map egg-conversion-map
 276                                (egg-bunsetsu-info) (cons egg-conversion-backend
 277                                                          bunsetsu-info)
 278                                'egg-bunsetsu-last last))))
 279
 280 (defun egg-insert-bunsetsu-list (bunsetsu-info-list &optional last)
 281   (let ((l bunsetsu-info-list)
 282         bunsetsu-info bunsetsu p)
 283     (while l
 284       (setq bunsetsu-info (car l)
 285             l (cdr l)
 286             p (point))
 287       (egg-insert-bunsetsu bunsetsu-info (and (null l) last)))))
 288
 289 (defun egg-backward-bunsetsu (n)
 290   (interactive "p")
 291   (let (start)
 292     (while (and (null start) (> n 0))
 293       (backward-char)
 294       (if (setq start (get-text-property (point) 'egg-start))
 295           (forward-char)
 296         (setq n (1- n))))
 297     (if (> n 0)
 298         (signal 'beginning-of-buffer nil))))
 299
 300 (defun egg-forward-bunsetsu (n)
 301   (interactive "p")
 302   (let (end)
 303     (while (and (null end) (> n 0))
 304       (forward-char)
 305       (if (setq end (get-text-property (point) 'egg-end))
 306           (backward-char)
 307         (setq n (1- n))))
 308     (if (> n 0)
 309         (signal 'end-of-buffer nil))))
 310
 311 (defun egg-get-previous-bunsetsu (p)
 312   (and (null (get-text-property (1- p) 'egg-start))
 313        (null (get-text-property (1- p) 'egg-bunsetsu-last))
 314        (egg-get-bunsetsu-info (- p 2))))
 315
 316 (defun egg-separate-characters (str)
 317   (let* ((v (string-to-vector str))
 318          (len (length v))
 319          (i 0) (j 0) m n (nchar 0))
 320     (while (< i len)
 321       (if (setq n (egg-chinese-syllable str j))
 322           (setq m (chars-in-string (substring str j (+ j n))))
 323         (setq m 1 n (char-bytes (aref v i))))
 324       (put-text-property j (+ j n) 'egg-char-size n str)
 325       (setq nchar (1+ nchar) i (+ i m) j (+ j n)))
 326     nchar))
 327
 328 (defun egg-shrink-bunsetsu (n)
 329   (interactive "p")
 330   (egg-enlarge-bunsetsu (- n)))
 331
 332 (defun egg-enlarge-bunsetsu (n)
 333   (interactive "p")
 334   (let* ((b0 (egg-get-previous-bunsetsu (point)))
 335          (b1 (egg-get-bunsetsu-info (point)))
 336          (s1 (egg-get-bunsetsu-source b1))
 337          (s1len (egg-separate-characters s1))
 338          (s2len 0)
 339          (chrs (length s1))
 340          (last (get-text-property (point) 'egg-bunsetsu-last))
 341          b2 s2 source bunsetsu-info-list beep)
 342     (if (not last)
 343         (let ((p2 (save-excursion (forward-char) (point))))
 344           (setq b2 (egg-get-bunsetsu-info p2)
 345                 s2 (egg-get-bunsetsu-source b2)
 346                 s2len (egg-separate-characters s2)
 347                 last (get-text-property p2 'egg-bunsetsu-last))))
 348     (setq source (concat s1 s2))
 349     (cond
 350      ((<= n (- s1len))
 351       (setq beep t chrs (get-text-property 0 'egg-char-size source)))
 352      ((> n s2len)
 353       (setq beep t chrs (length source)))
 354      ((< n 0)
 355       (while (< n 0)
 356         (setq chrs (- chrs (get-text-property (1- chrs) 'egg-char-size source))
 357               n (1+ n))))
 358      (t
 359       (while (> n 0)
 360         (setq chrs (+ chrs (get-text-property chrs 'egg-char-size source))
 361               n (1- n)))))
 362     (setq bunsetsu-info-list (egg-change-bunsetsu-length b0 b1 b2 chrs))
 363     (delete-region (point)
 364                    (progn (forward-char) (if b2 (forward-char)) (point)))
 365     (let ((p (point)))
 366       (egg-insert-bunsetsu-list bunsetsu-info-list last)
 367       (goto-char p))
 368     (if beep
 369         (ding))))
 370
 371 (defun egg-next-candidate (n)
 372   (interactive "p")
 373   (let ((last (get-text-property (point) 'egg-bunsetsu-last))
 374         (b (egg-get-bunsetsu-info (point)))
 375         new i max+ p beep)
 376     (setq max+ (egg-get-number-of-candidates b))
 377     (if (null max+)
 378         (let ((prev-b (egg-get-previous-bunsetsu (point))))
 379           (setq i (egg-list-candidates b prev-b)) ; there is a case I=/=0
 380           (if (or (> n 1) (< n 0))      ; with N=/=1, start with I
 381               (setq i (+ n i))          ; or else (N==1),
 382             (setq i (if (= i 0) 1 0)))  ;   I:=1 when I was 0, or else I:=0
 383           (setq max+ (egg-get-number-of-candidates b)))
 384       (setq i (egg-get-current-candidate-number b))
 385       (setq i (+ n i)))
 386     (if (< i 0)                         ; go backward as if it is ring
 387         (while (< i 0)
 388           (setq i (+ i max+))))
 389     (if (>= i max+)                     ; don't go forward
 390         (setq i (1- max+)
 391               beep t))
 392     (setq new (egg-decide-candidate b i))
 393     (setq p (point))
 394     (delete-region p (progn (forward-char) (point)))
 395     (egg-insert-bunsetsu new last)
 396     (goto-char p)
 397     (if beep
 398         (ding))))
 399
 400 (defun egg-previous-candidate (n)
 401   (interactive "p")
 402   (egg-next-candidate (- n)))
 403
 404 (defun egg-decide-before-point ()
 405   (interactive)
 406   (let (bunsetsu-list bl (p (point)) source (dlen 0) l s)
 407     (save-restriction
 408       (if (null (get-text-property (1- (point)) 'egg-start))
 409           (goto-char (previous-single-property-change (point) 'egg-start)))
 410       (narrow-to-region (1- (point)) p)
 411       (setq source (get-text-property (1- (point)) 'egg-source))
 412       (setq bunsetsu-list (setq bl (list nil)))
 413       (while (< (point) (point-max))
 414         ;; delete sparator/open marker
 415         (delete-region (1- (point)) (point))
 416         (setq bl (setcdr bl (list (egg-get-bunsetsu-info (point)))))
 417         (setq dlen (+ dlen (length (egg-get-bunsetsu-source (car bl)))))
 418         (if (get-text-property (point) 'egg-bunsetsu-last)
 419             (progn
 420               (egg-end-conversion (cdr bunsetsu-list))
 421               (setq bunsetsu-list (setq bl (list nil)))))
 422         (setq p (point))
 423         (forward-char)
 424         (remove-text-properties p (point) '(face nil
 425                                                  intangible nil
 426                                                  local-map nil
 427                                                  egg-bunsetsu-last nil))))
 428     (if (get-text-property (point) 'egg-end)
 429         (progn
 430           ;; delete close marker
 431           (delete-region (point) (1+ (point)))
 432           (egg-do-auto-fill)
 433           (run-hooks 'input-method-after-insert-chunk-hook))
 434       ;; delete last from speparater to close marker
 435       (delete-region (1- (point))
 436                      (1+ (next-single-property-change (point) 'egg-end)))
 437       ;; rebuild fence mode string
 438       (setq p 0)
 439       (while (< p dlen)
 440         (setq s (car (get-text-property p 'its-syl source))
 441               l (length s)
 442               p (+ p l))
 443         (if (> p dlen)
 444             (put-text-property dlen p
 445                                'its-syl (list (substring s (- dlen p)))
 446                                source)))
 447       (its-restart (substring source dlen)))))
 448
 449 (defun egg-exit-conversion ()
 450   (interactive)
 451   (goto-char (next-single-property-change (point) 'egg-end))
 452   (egg-decide-before-point))
 453
 454 (defun egg-abort-conversion ()
 455   (interactive)
 456   (if (null (get-text-property (1- (point)) 'egg-start))
 457       (goto-char (previous-single-property-change (point) 'egg-start)))
 458   (egg-decide-before-point))
 459
 460 (defun egg-select-candidate ()
 461   (interactive)
 462   (let ((last (get-text-property (point) 'egg-bunsetsu-last))
 463         (b (egg-get-bunsetsu-info (point)))
 464         (in-loop t)
 465         new i max+ p)
 466     (setq max+ (egg-get-number-of-candidates b))
 467     (if (null max+)
 468         (let ((prev-b (egg-get-previous-bunsetsu (point))))
 469           (setq i (egg-list-candidates b prev-b))
 470           (setq max+ (egg-get-number-of-candidates b)))
 471       (setq i (egg-get-current-candidate-number b)))
 472     (let* ((candidate-list (egg-get-all-candidates b))
 473            (l candidate-list)
 474            (candidate (menudiag-select (list 'menu "\e$B8uJd\e(B:" l) (list (nth i l)))))
 475       (setq i 0)
 476       (while in-loop
 477         (if (eq candidate (car l))
 478             (setq in-loop nil)
 479           (setq l (cdr l)
 480                 i (1+ i))))
 481       (setq new (egg-decide-candidate b i))
 482       (setq p (point))
 483       (delete-region p (progn (forward-char) (point)))
 484       (egg-insert-bunsetsu new last)
 485       (goto-char p))))
 486
 487 (provide 'egg-cnv)
 488 ;;; egg-cnv.el ends here.