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         (setq s (point)
 133               e (next-single-property-change s 'egg-lang nil (point-max)))
 134         (setq bunsetsu-info-list
 135               (egg-start-conversion (buffer-substring s e) lang))
 136         (setq contin (< e (point-max)))
 137         (delete-region s e)
 138         (egg-insert-bunsetsu-list bunsetsu-info-list
 139                                   (if (< (point) (point-max)) 'contine t))))
 140     (setq p (point))
 141     (insert egg-conversion-close)
 142     (put-text-property p (point) 'egg-end t)
 143     (if egg-conversion-face
 144         (put-text-property p (point) 'invisible t))
 145     (goto-char start)))
 146
 147 (defun egg-separate-languages (start end)
 148   (let (lang last-lang last-chinese p l c cset)
 149     (goto-char start)
 150     (while (< (point) end)
 151       (setq p (next-single-property-change (point) 'its-lang nil end))
 152       (cond
 153        ((get-text-property (point) 'its-lang)
 154         (goto-char p))
 155        ((setq l (egg-chinese-syllable (buffer-substring (point) p)))
 156         (setq p (point))
 157         (goto-char (+ (point) l))
 158         (put-text-property p (point) 'its-lang "Chinese"))
 159        ((progn
 160           (setq c (following-char)
 161                 cset (char-charset c))
 162           (eq cset 'chinese-sisheng))
 163         (setq p (point))
 164         (forward-char)
 165         (put-text-property p (point) 'its-lang "Chinese"))
 166        ((eq cset 'ascii)
 167         (forward-char))
 168        (t
 169         (setq p (point))
 170         (forward-char)
 171         (put-text-property p (point) 'its-lang (egg-char-to-language c)))))
 172     (goto-char start)
 173     (while (< (point) end)
 174       (setq lang (get-text-property (point) 'its-lang))
 175       (cond
 176        ((null lang)
 177         (setq lang (or last-lang
 178                        (egg-next-part-lang end))))
 179        ((equal lang "Chinese")
 180         (setq lang (or last-chinese
 181                        (egg-next-chinese-lang end)))))
 182       (setq last-lang lang)
 183       (if (or (equal lang "Chinese-GB") (equal lang "Chinese-CNS"))
 184           (setq last-chinese lang))
 185       (setq p (point))
 186       (goto-char (next-single-property-change (point) 'its-lang nil end))
 187       (set-text-properties p (point) (list 'egg-lang lang)))))
 188
 189 (defun egg-char-to-language (c)
 190   (let ((charset (char-charset c))
 191         (list language-info-alist))
 192     (while (and list
 193                 (null (memq charset (assq 'charset (car list)))))
 194       (setq list (cdr list)))
 195     (car (car list))))
 196
 197 (defun egg-next-part-lang (end)
 198   (let* ((p (next-single-property-change (point) 'its-lang nil end))
 199          (lang (get-text-property p 'its-lang)))
 200     (if (equal lang "Chinese")
 201         (egg-next-chinese-lang end)
 202       (or lang
 203           its-current-language
 204           egg-default-language))))
 205
 206 (defun egg-next-chinese-lang (end)
 207   (let (p lang)
 208     (setq p (point))
 209     (while (and (< p end) (null lang))
 210       (setq p (next-single-property-change p 'its-lang nil end))
 211       (setq lang (get-text-property p 'its-lang))
 212       (if (null (or (equal lang "Chinese-GB")
 213                     (equal lang "Chinese-CNS")))
 214           (setq lang nil)))
 215     (cond
 216      (lang lang)
 217      ((or (equal its-current-language "Chinese-GB")
 218           (equal its-current-language "Chinese-CNS"))
 219       its-current-language)
 220      ((or (equal egg-default-language "Chinese-GB")
 221           (equal egg-default-language "Chinese-CNS"))
 222       egg-default-language)
 223      (t "Chinese-GB"))))
 224 \f
 225 (defvar egg-conversion-face nil)
 226 (defvar egg-conversion-map
 227   (let ((map (make-sparse-keymap))
 228         (i 33))
 229     (while (< i 127)
 230       (define-key map (vector i) 'egg-exit-conversion-unread-char)
 231       (setq i (1+ i)))
 232     (define-key map "\C-@" 'egg-decide-first-char)
 233     (define-key map [?\C-\ ] 'egg-decide-first-char)
 234     (define-key map "\C-a"   'egg-beginning-of-conversion-buffer)
 235     (define-key map "\C-b"   'egg-backward-bunsetsu)
 236     (define-key map "\C-c"   'egg-abort-conversion)
 237     (define-key map "\C-e"   'egg-end-of-conversion-buffer)
 238     (define-key map "\C-f"   'egg-forward-bunsetsu)
 239     (define-key map "\C-h"   'egg-help-command)
 240     (define-key map "\C-i"   'egg-shrink-bunsetsu)
 241     (define-key map "\C-k"   'egg-decide-before-point)
 242 ;;    (define-key map "\C-l"   'egg-exit-conversion)  ; Don't override C-L
 243     (define-key map "\C-m"   'egg-exit-conversion)
 244     (define-key map "\C-n"   'egg-next-candidate)
 245     (define-key map "\C-o"   'egg-enlarge-bunsetsu)
 246     (define-key map "\C-p"   'egg-previous-candidate)
 247     (define-key map "\M-s"   'egg-select-candidate)
 248     (define-key map [return] 'egg-exit-conversion)
 249 ;;    (define-key map "\C-\\"  'egg-exit-mode-no-egg)
 250     (define-key map [right]  'egg-forward-bunsetsu)
 251     (define-key map [left]   'egg-backward-bunsetsu)
 252     (define-key map " "      'egg-next-candidate)
 253     (define-key map "/"      'egg-exit-conversion)
 254     map)
 255   "Keymap for EGG Conversion mode.")
 256
 257 (defun egg-exit-conversion-unread-char ()
 258   (interactive)
 259   (setq unread-command-events (list last-command-event))
 260   (egg-exit-conversion))
 261
 262 (defun egg-insert-bunsetsu (bunsetsu-info last)
 263   (let ((bunsetsu (egg-get-bunsetsu-converted bunsetsu-info))
 264         (p (point)))
 265     (insert bunsetsu)
 266     (if (null (eq last t))
 267         (insert egg-conversion-separator))
 268     (add-text-properties p (point)
 269                          (list 'face      egg-conversion-face
 270                                'local-map egg-conversion-map
 271                                (egg-bunsetsu-info) (cons egg-conversion-backend
 272                                                          bunsetsu-info)
 273                                'egg-bunsetsu-last last))))
 274
 275 (defun egg-insert-bunsetsu-list (bunsetsu-info-list &optional last)
 276   (let ((l bunsetsu-info-list)
 277         bunsetsu-info bunsetsu p)
 278     (while l
 279       (setq bunsetsu-info (car l)
 280             l (cdr l)
 281             p (point))
 282       (egg-insert-bunsetsu bunsetsu-info (and (null l) last)))))
 283
 284 (defun egg-backward-bunsetsu (n)
 285   (interactive "p")
 286   (let (start)
 287     (while (and (null start) (> n 0))
 288       (backward-char)
 289       (if (setq start (get-text-property (point) 'egg-start))
 290           (forward-char)
 291         (setq n (1- n))))
 292     (if (> n 0)
 293         (signal 'beginning-of-buffer nil))))
 294
 295 (defun egg-forward-bunsetsu (n)
 296   (interactive "p")
 297   (let (end)
 298     (while (and (null end) (> n 0))
 299       (forward-char)
 300       (if (setq end (get-text-property (point) 'egg-end))
 301           (backward-char)
 302         (setq n (1- n))))
 303     (if (> n 0)
 304         (signal 'end-of-buffer nil))))
 305
 306 (defun egg-get-previous-bunsetsu (p)
 307   (and (null (get-text-property (1- p) 'egg-start))
 308        (null (get-text-property (1- p) 'egg-bunsetsu-last))
 309        (egg-get-bunsetsu-info (- p 2))))
 310
 311 (defun egg-separate-characters (str)
 312   (let* ((v (string-to-vector str))
 313          (len (length v))
 314          (i 0) (j 0) m n (nchar 0))
 315     (while (< i len)
 316       (if (setq n (egg-chinese-syllable str j))
 317           (setq m (chars-in-string (substring str j (+ j n))))
 318         (setq m 1 n (char-bytes (aref v i))))
 319       (put-text-property j (+ j n) 'egg-char-size n str)
 320       (setq nchar (1+ nchar) i (+ i m) j (+ j n)))
 321     nchar))
 322
 323 (defun egg-shrink-bunsetsu (n)
 324   (interactive "p")
 325   (egg-enlarge-bunsetsu (- n)))
 326
 327 (defun egg-enlarge-bunsetsu (n)
 328   (interactive "p")
 329   (let* ((b0 (egg-get-previous-bunsetsu (point)))
 330          (b1 (egg-get-bunsetsu-info (point)))
 331          (s1 (egg-get-bunsetsu-source b1))
 332          (s1len (egg-separate-characters s1))
 333          (s2len 0)
 334          (chrs (length s1))
 335          (last (get-text-property (point) 'egg-bunsetsu-last))
 336          b2 s2 source bunsetsu-info-list beep)
 337     (if (not last)
 338         (let ((p2 (save-excursion (forward-char) (point))))
 339           (setq b2 (egg-get-bunsetsu-info p2)
 340                 s2 (egg-get-bunsetsu-source b2)
 341                 s2len (egg-separate-characters s2)
 342                 last (get-text-property p2 'egg-bunsetsu-last))))
 343     (setq source (concat s1 s2))
 344     (cond
 345      ((<= n (- s1len))
 346       (setq beep t chrs (get-text-property 0 'egg-char-size source)))
 347      ((> n s2len)
 348       (setq beep t chrs (length source)))
 349      ((< n 0)
 350       (while (< n 0)
 351         (setq chrs (- chrs (get-text-property (1- chrs) 'egg-char-size source))
 352               n (1+ n))))
 353      (t
 354       (while (> n 0)
 355         (setq chrs (+ chrs (get-text-property chrs 'egg-char-size source))
 356               n (1- n)))))
 357     (setq bunsetsu-info-list (egg-change-bunsetsu-length b0 b1 b2 chrs))
 358     (delete-region (point)
 359                    (progn (forward-char) (if b2 (forward-char)) (point)))
 360     (let ((p (point)))
 361       (egg-insert-bunsetsu-list bunsetsu-info-list last)
 362       (goto-char p))
 363     (if beep
 364         (ding))))
 365
 366 (defun egg-next-candidate (n)
 367   (interactive "p")
 368   (let ((last (get-text-property (point) 'egg-bunsetsu-last))
 369         (b (egg-get-bunsetsu-info (point)))
 370         new i max+ p beep)
 371     (setq max+ (egg-get-number-of-candidates b))
 372     (if (null max+)
 373         (let ((prev-b (egg-get-previous-bunsetsu (point))))
 374           (setq i (egg-list-candidates b prev-b)) ; there is a case I=/=0
 375           (if (or (> n 1) (< n 0))      ; with N=/=1, start with I
 376               (setq i (+ n i))          ; or else (N==1),
 377             (setq i (if (= i 0) 1 0)))  ;   I:=1 when I was 0, or else I:=0
 378           (setq max+ (egg-get-number-of-candidates b)))
 379       (setq i (egg-get-current-candidate-number b))
 380       (setq i (+ n i)))
 381     (if (< i 0)                         ; go backward as if it is ring
 382         (while (< i 0)
 383           (setq i (+ i max+))))
 384     (if (>= i max+)                     ; don't go forward
 385         (setq i (1- max+)
 386               beep t))
 387     (setq new (egg-decide-candidate b i))
 388     (setq p (point))
 389     (delete-region p (progn (forward-char) (point)))
 390     (egg-insert-bunsetsu new last)
 391     (goto-char p)
 392     (if beep
 393         (ding))))
 394
 395 (defun egg-previous-candidate (n)
 396   (interactive "p")
 397   (egg-next-candidate (- n)))
 398
 399 ;; Bogus function 980220
 400 (defun egg-decide-bunsetsu (&optional end-marker)
 401   (let ((in-loop t)
 402         p bunsetsu-info-list bl)
 403     (setq p (point))
 404     (while in-loop
 405       (let ((bl1 (cons (egg-get-bunsetsu-info p) nil)))
 406         (if bl
 407             (setq bl (setcdr bl bl1))
 408           (setq bunsetsu-info-list (setq bl bl1))))
 409       (forward-char)
 410       (remove-text-properties p (point) '(face nil
 411                                           intangible nil
 412                                           local-map nil
 413                                           egg-bunsetsu-last nil))
 414       (setq p (point))
 415       (if (or (and end-marker (= p end-marker))
 416               (get-text-property p 'egg-end))
 417           (setq in-loop nil)
 418         (setq p (1- p))
 419         (delete-region p (1+ p))))      ; Delete bunsetsu separator
 420     bunsetsu-info-list))
 421
 422 (defun egg-decide-before-point ()
 423   (interactive)
 424   (let (bunsetsu-list bl (p (point)) source (dlen 0) l s)
 425     (save-restriction
 426       (if (null (get-text-property (1- (point)) 'egg-start))
 427           (goto-char (previous-single-property-change (point) 'egg-start)))
 428       (narrow-to-region (1- (point)) p)
 429       (setq source (get-text-property (1- (point)) 'egg-source))
 430       (setq bunsetsu-list (setq bl (list nil)))
 431       (while (< (point) (point-max))
 432         ;; delete sparator/open marker
 433         (delete-region (1- (point)) (point))
 434         (setq bl (setcdr bl (list (egg-get-bunsetsu-info (point)))))
 435         (setq dlen (+ dlen (length (egg-get-bunsetsu-source (car bl)))))
 436         (if (get-text-property (point) 'egg-bunsetsu-last)
 437             (progn
 438               (egg-end-conversion (cdr bunsetsu-list))
 439               (setq bunsetsu-list (setq bl (list nil)))))
 440         (setq p (point))
 441         (forward-char)
 442         (remove-text-properties p (point) '(face nil
 443                                                  intangible nil
 444                                                  local-map nil
 445                                                  egg-bunsetsu-last nil))))
 446     (if (get-text-property (point) 'egg-end)
 447         (progn
 448           ;; delete close marker
 449           (delete-region (point) (1+ (point)))
 450           (egg-do-auto-fill)
 451           (run-hooks 'input-method-after-insert-chunk-hook))
 452       ;; delete last from speparater to close marker
 453       (delete-region (1- (point))
 454                      (1+ (next-single-property-change (point) 'egg-end)))
 455       ;; rebuild fence mode string
 456       (setq p 0)
 457       (while (< p dlen)
 458         (setq s (car (get-text-property p 'its-syl source))
 459               l (length s)
 460               p (+ p l))
 461         (if (> p dlen)
 462             (put-text-property dlen p
 463                                'its-syl (list (substring s (- dlen p)))
 464                                source)))
 465       (its-restart (substring source dlen)))))
 466
 467 (defun egg-exit-conversion ()
 468   (interactive)
 469   (goto-char (next-single-property-change (point) 'egg-end))
 470   (egg-decide-before-point))
 471
 472 (defun egg-abort-conversion ()
 473   (interactive)
 474   (if (null (get-text-property (1- (point)) 'egg-start))
 475       (goto-char (previous-single-property-change (point) 'egg-start)))
 476   (egg-decide-before-point))
 477
 478 (defun egg-select-candidate ()
 479   (interactive)
 480   (let ((last (get-text-property (point) 'egg-bunsetsu-last))
 481         (b (egg-get-bunsetsu-info (point)))
 482         (in-loop t)
 483         new i max+ p)
 484     (setq max+ (egg-get-number-of-candidates b))
 485     (if (null max+)
 486         (let ((prev-b (egg-get-previous-bunsetsu (point))))
 487           (setq i (egg-list-candidates b prev-b))
 488           (setq max+ (egg-get-number-of-candidates b)))
 489       (setq i (egg-get-current-candidate-number b)))
 490     (let* ((candidate-list (egg-get-all-candidates b))
 491            (l candidate-list)
 492            (candidate (menudiag-select (list 'menu "\e$B8uJd\e(B:" l) (list (nth i l)))))
 493       (setq i 0)
 494       (while in-loop
 495         (if (eq candidate (car l))
 496             (setq in-loop nil)
 497           (setq l (cdr l)
 498                 i (1+ i))))
 499       (setq new (egg-decide-candidate b i))
 500       (setq p (point))
 501       (delete-region p (progn (forward-char) (point)))
 502       (egg-insert-bunsetsu new last)
 503       (goto-char p))))
 504
 505 (provide 'egg-cnv)
 506 ;;; egg-cnv.el ends here.