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