its.el

   1 ;;; its.el --- Input Translation Systam AKA "ITS(uDekirunDa!)"
   2
   3 ;; Copyright (C) 1997, 1998 Mule Project, Powered by Electrotechnical
   4 ;; 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 ;;; Code:
  32
  33 (require 'cl)
  34
  35 (defvar its-current-map nil)
  36 (make-variable-buffer-local 'its-current-map)
  37 (put 'its-current-map 'permanent-local t)
  38
  39 (defvar its-current-select-func nil)
  40 (make-variable-buffer-local 'its-current-select-func)
  41 (put 'its-current-select-func 'permanent-local t)
  42
  43 (defvar its-previous-select-func nil)
  44 (make-variable-buffer-local 'its-previous-select-func)
  45 (put 'its-previous-select-func 'permanent-local t)
  46
  47 (defvar its-current-language)
  48 (make-variable-buffer-local 'its-current-language)
  49 (put 'its-current-language 'permanent-local t)
  50 \f
  51 ;; Data structure in ITS
  52 ;; (1) SYL and CURSOR
  53 ;;
  54 ;; "SYL" stands for something like a syllable.
  55 ;;
  56 ;; <SYL> ::= ( <output> . ( <keyseq> . <terminal> ))   ; Determined:   DSYL
  57 ;;        |  <state>                            ; Intermediate: ISYL
  58 ;;        |  ( <output> . <point> )             ; Verbatim:     VSYL
  59 ;;        |  nil                                ; None
  60 ;;
  61 ;; ;<state> ::=
  62 ;; ;          ( <output> . ( <keyseq> . <key-state-table/terminal> ))
  63 ;;
  64 ;; <keyseq> ::= "string" of key sequence
  65 ;; <output> ::= "string"
  66 ;;
  67 ;; <point> ::= integer which specifies point
  68 ;;
  69 ;; <cursor> ::= nil        ; Previous SYL is active (input will go that SYL)
  70 ;;           |  t          ; input makes new SYL.  DEL deletes previous SYL
  71 ;;           |  its-cursor ; DEL breaks previous SYL, input makes new SYL
  72
  73 ;; Data structures in ITS
  74 ;; (2) State machine which recognizes SYL
  75 ;;
  76 ;; <state> ::= ( <output> <keyseq> . <key-state-table/terminal> )
  77 ;;
  78 ;; <key-state-table/terminal> ::= <key-state-table> ; intermediate state
  79 ;;                             |  <terminal>        ; terminal state
  80 ;;
  81 ;; <key-state-table> ::= ( <key-state-alist> . <expr-output-back-list> )
  82 ;; <key-state-alist> ::= ( <key-state> ... )
  83 ;; <key-state> ::= ( <key> . <state> )
  84 ;; <key> ::= Positive INTEGER which specifies KEY STROKE
  85 ;;        |  -1 ; means END of key stroke
  86 ;;
  87 ;; Only applicable for last transition.
  88 ;; <expr-output-back-list> ::= ( (<output> . (<keyexpr> . <howmanyback>))... )
  89 ;; <keyexpr> ::= something like "[a-z]" which specifies class of key.
  90 ;;            |  NIL; means ANY of key (except END of the key stroke)
  91 ;;
  92 ;;
  93 ;; <keyseq> ::= "string"
  94 ;;
  95 ;; <terminal> ::= nil
  96 ;;             |  <howmanyback>
  97 ;;
  98 ;; <howmanyback> ::= integer which specifies how many key strokes we go back
  99 ;;
 100 ;; <output> ::= "string"
 101
 102 ;; Data structure in ITS (3) Map
 103 ;;
 104 ;; <map>         ::= ( <name> <indicator> <language> . <start-state> )
 105 ;; <name>        ::= "string"
 106 ;; <indicator>   ::= "string"
 107 ;; <language>    ::= "string"
 108 ;; <start-state> ::= <state>
 109 ;;
 110 \f
 111 (defsubst its-new-state (output keyseq back)
 112   (cons output (cons keyseq back)))
 113
 114 (defsubst its-new-map (name indicator language)
 115   (cons name (cons indicator (cons language (its-new-state "" "" nil)))))
 116
 117 (defsubst its-get-indicator (map)
 118   (nth 1 map))
 119
 120 (defsubst its-get-language (map)
 121   (nth 2 map))
 122
 123 (defsubst its-get-start-state (map)
 124   (nthcdr 3 map))
 125
 126 (defsubst its-get-kst/t (state)
 127   (cdr (cdr state)))
 128
 129 (defsubst its-set-kst (state kst)
 130   (setcdr (cdr state) kst))
 131
 132 (defsubst its-get-keyseq (state)
 133   (car (cdr state)))
 134
 135 (defsubst its-set-keyseq (state keyseq)
 136   (setcar (cdr state) keyseq))
 137
 138 (defun its-get-keyseq-cooked (state)
 139   (let ((keyseq (its-get-keyseq state))
 140         (back (its-get-kst/t state)))
 141     (if back
 142         (substring keyseq 0 back)
 143       keyseq)))
 144
 145 (defsubst its-kst-p (kst/t)
 146   (not (or (numberp kst/t) (null kst/t))))
 147
 148 (defsubst its-get-output (syl/state)
 149   (car syl/state))
 150
 151 (defsubst its-set-output (state output)
 152   (setcar state output))
 153
 154 (defsubst its-get-keyseq-syl (syl)
 155   (let ((l (cdr syl)))
 156     (cond ((stringp l)                  ; DSYL
 157            l)
 158           ((numberp l)                  ; VSYL
 159            (car syl))
 160           ((numberp (cdr l))
 161            (substring (car l) 0 (cdr l)))
 162           (t
 163            (car l)))))
 164
 165 (defsubst its-eob-keyexpr (eob)
 166   (car (cdr eob)))
 167 (defsubst its-eob-back (eob)
 168   (cdr (cdr eob)))
 169
 170 (defsubst its-make-class+back (class back)
 171   (cons class back))
 172 (defsubst its-make-otherwise (output class+back)
 173   (cons output class+back))
 174
 175 (defsubst its-DSYL-with-back-p (syl)
 176   (and (consp (cdr syl))
 177        (numberp (its-get-kst/t syl))))
 178
 179 (defsubst its-concrete-DSYL-p (syl)
 180   (stringp (cdr syl)))
 181
 182 (defsubst its-make-concrete-DSYL (syl)
 183   (if (consp (cdr syl))
 184       (cons (its-get-output syl) (its-get-keyseq-syl syl))
 185     syl))
 186
 187 ;;
 188 ;;
 189
 190 (eval-when (eval load compile)
 191   (require 'its-keydef))
 192
 193 (defvar its-mode-map
 194   (let ((map (make-sparse-keymap))
 195         (i 33))
 196     (define-key map "\C-a" 'its-beginning-of-input-buffer)
 197     (define-key map "\C-b" 'its-backward-SYL)
 198     (define-key map "\C-c" 'its-cancel-input)
 199     (define-key map "\C-d" 'its-delete-SYL)
 200     (define-key map "\C-e" 'its-end-of-input-buffer)
 201     (define-key map "\C-f" 'its-forward-SYL)
 202     (define-key map "\C-g" 'its-select-previous-mode)
 203     (define-key map "\C-]" 'its-cancel-input)
 204     (define-key map "\C-h" 'its-mode-help-command)
 205     (define-key map "\C-k" 'its-kill-line)
 206 ;;    (define-key map "\C-l" 'its-exit-mode)
 207     (define-key map "\C-m" 'its-exit-mode)      ; RET
 208     (define-key map [return] 'its-exit-mode)
 209     (define-key map "\C-t" 'its-transpose-chars)
 210     (define-key map "\C-w" 'its-kick-convert-region)
 211     (define-key map "\C-y" 'its-yank)
 212     (define-key map "\M-y" 'its-yank-pop)
 213     (define-key map [backspace] 'its-delete-backward-SYL)
 214     (define-key map [delete] 'its-delete-backward-SYL)
 215     (define-key map [M-backspace] 'its-delete-backward-SYL-by-keystroke)
 216     (define-key map [M-delete] 'its-delete-backward-SYL-by-keystroke)
 217     (define-key map [right] 'its-forward-SYL)
 218     (define-key map [left] 'its-backward-SYL)
 219     (while (< i 127)
 220       (define-key map (vector i) 'its-self-insert-char)
 221       (setq i (1+ i)))
 222     (define-key map " "    'its-kick-convert-region-or-self-insert)
 223     (define-key map "\177" 'its-delete-backward-SYL)
 224     ;;
 225     (define-key map "\M-p" 'its-previous-map)
 226     (define-key map "\M-n" 'its-next-map)
 227     (define-key map "\M-h" 'its-hiragana) ; hiragana-region for input-buffer
 228     (define-key map "\M-k" 'its-katakana)
 229     (define-key map "\M-<" 'its-hankaku)
 230     (define-key map "\M->" 'its-zenkaku)
 231     (its-define-select-keys map t)
 232     map)
 233   "Keymap for ITS mode.")
 234
 235 (defvar its-fence-open  "|" "*\e$B%U%'%s%9$N;OE@$r<($9J8;zNs\e(B (1 \e$BJ8;z0J>e\e(B)")
 236 (defvar its-fence-close "|" "*\e$B%U%'%s%9$N=*E@$r<($9J8;zNs\e(B (1 \e$BJ8;z0J>e\e(B)")
 237 (defvar its-fence-face  nil "*\e$B%U%'%s%9I=<($KMQ$$$k\e(B face \e$B$^$?$O\e(B nil")
 238
 239 (defconst its-setup-fence-before-insert-SYL nil)
 240
 241 (defun its-get-fence-face ()
 242   (let ((face (and (consp its-fence-face)
 243                    (or (assoc its-current-language its-fence-face)
 244                        (assoc t its-fence-face)))))
 245     (if face (cdr face) its-fence-face)))
 246
 247 (defun its-put-cursor (cursor)
 248   (let ((p (point))
 249         (map (copy-keymap its-mode-map)))
 250     (its-define-select-keys map)
 251     (insert "!")
 252     (add-text-properties p (point) (list 'local-map map
 253                                          'read-only t
 254                                          'invisible t
 255                                          'intangible 'its-part-2
 256                                          'its-cursor cursor))
 257     (goto-char p)))
 258
 259 (defsubst its-set-cursor-status (cursor)
 260   (put-text-property (point) (1+ (point)) 'its-cursor cursor)
 261   cursor)
 262
 263 ;;
 264 ;;  +-- START property
 265 ;;  |          --- CURSOR Property
 266 ;;  |         /
 267 ;;  v        v    v-- END Property
 268 ;;  |SYL SYL ^ SYL|
 269 ;;   ^^^ ^^^   ^^^------ SYL Property
 270 ;;  <-------><---->
 271 ;; intangible intangible
 272 ;;     1       2
 273 ;;
 274 (defun its-setup-fence-mode ()
 275   (let ((open-props '(its-start t intangible its-part-1))
 276         (close-props '(rear-nonsticky t its-end t intangible its-part-2))
 277         (p (point)) p1)
 278     ;; Put open-fence before inhibit-read-only to detect read-nly
 279     (insert its-fence-open)
 280     (let ((inhibit-read-only t))
 281       (setq p1 (point))
 282       (add-text-properties p p1 open-props)
 283       (insert its-fence-close)
 284       (add-text-properties p1 (point) close-props)
 285       (if its-fence-face
 286           (put-text-property p (point) 'invisible t))
 287       (put-text-property p (point) 'read-only t)
 288       (goto-char p1)
 289       (its-put-cursor t))))
 290
 291 (defun its-start (key)
 292   (let ((its-setup-fence-before-insert-SYL t))
 293     (its-input nil key)))
 294
 295 (defun its-restart (str &optional set-prop)
 296   (let (p)
 297     (its-setup-fence-mode)
 298     (setq p (point))
 299     (insert str)
 300     (if set-prop
 301         (its-setup-yanked-portion p (point)))
 302     (its-beginning-of-input-buffer)))
 303
 304 (defun its-self-insert-char ()
 305   (interactive)
 306   (let ((inhibit-read-only t)
 307         (key last-command-char)
 308         (cursor (get-text-property (point) 'its-cursor))
 309         (syl (get-text-property (1- (point)) 'its-syl)))
 310     (cond
 311      ((or (eq cursor t)
 312           (not (eq (get-text-property (1- (point)) 'its-map) its-current-map)))
 313       (put-text-property (- (point) (length (its-get-output syl))) (point)
 314                          'its-syl (its-make-concrete-DSYL syl))
 315       (setq syl nil))
 316     (cursor
 317      (setq syl nil)))
 318     (its-input syl key)))
 319
 320 (defun its-initial-ISYL ()
 321   (its-get-start-state its-current-map))
 322
 323 (defun its-make-VSYL (keyseq)
 324   (cons keyseq (length keyseq)))
 325
 326 (defvar its-barf-on-invalid-keyseq nil
 327   "T means don't allow invalid key sequence in input buffer.")
 328
 329 (defun its-input-error ()
 330   (error "Invalid Romaji Sequence"))
 331
 332 ;; Return CURSOR
 333 (defun its-input (syl key)
 334   (if (null syl)
 335       (setq syl (its-initial-ISYL)))
 336   (let ((output (car syl))
 337         (k/kk/s (cdr syl)))
 338     (cond
 339      ((numberp k/kk/s)
 340         ;; k/kk/s is "point in keyseq"
 341         (its-input-to-vsyl syl key k/kk/s output))
 342      ((and its-barf-on-invalid-keyseq
 343            (null (its-keyseq-acceptable-p (vector key) syl)))
 344       ;; signal before altering
 345       (its-input-error))
 346      (t
 347       ;; It's ISYL
 348       (its-state-machine syl key 'its-buffer-ins/del-SYL)))))
 349
 350 (defun its-input-to-vsyl (syl key point output)
 351   (if (< key 0)
 352       (its-set-cursor-status t)
 353     (let ((len (length output)))
 354       (if (= len point)
 355           ;; point is at end of VSYL.  Don't need to call state machine.
 356           (its-buffer-ins/del-SYL
 357            (its-make-VSYL (concat output (vector key))) syl nil)
 358         ;; point is at middle of VSYL.
 359         (let ((new-keyseq (concat (substring output 0 point)
 360                                   (vector key)
 361                                   (substring output point))))
 362           (its-state-machine-keyseq new-keyseq 'its-buffer-ins/del-SYL))))))
 363 \f
 364 ;;;
 365 ;;; ITS State Machine
 366 ;;;
 367
 368 (defvar its-disable-special-action nil)
 369
 370 ;; Return CURSOR
 371 (defun its-state-machine (state key emit)
 372   (let ((next-state (its-get-next-state state key))
 373         expr-output-back kst/t output keyseq back)
 374     (cond
 375      ;; proceed to next status
 376      ((and next-state
 377            (not (and its-disable-special-action
 378                      (eq (its-get-kst/t next-state) t))))
 379       (setq kst/t (its-get-kst/t next-state)
 380             output (its-get-output next-state)
 381             keyseq (its-get-keyseq next-state))
 382       (cond
 383        ;; Special actions.
 384        ((eq kst/t t)
 385         (funcall emit (cons "" keyseq) state 'its-cursor)
 386         (apply (car output) (cdr output)))
 387
 388        ;; Still, it's a intermediate state.
 389        ((its-kst-p kst/t)
 390         (funcall emit next-state state nil))
 391
 392        ;; It's negative integer which specifies how many
 393        ;; characters we go backwards
 394        (kst/t
 395         (funcall emit next-state state 'its-cursor)
 396         (its-state-machine-keyseq (substring keyseq kst/t) emit (< key 0)))
 397
 398        ;; Here we arrive to a terminal state.
 399        ;; Emit a DSYL, and go ahead.
 400        (t
 401         (funcall emit next-state state 'its-cursor))))
 402
 403      ;; push back by otherwise status
 404      ((and (>= key 0)
 405            (setq expr-output-back (its-get-otherwise state key)))
 406       (setq keyseq (concat (its-get-keyseq state) (vector key)))
 407       (funcall emit
 408                (cons (its-get-output expr-output-back)
 409                      (cons keyseq (its-eob-back expr-output-back)))
 410                state t)
 411       (its-state-machine-keyseq
 412        (substring keyseq (its-eob-back expr-output-back)) emit))
 413
 414      ((eq its-barf-on-invalid-keyseq 'its-keyseq-test)
 415       'its-keyseq-test-failed)
 416
 417      ;; No next state for KEY.  It's invalid sequence.
 418      (its-barf-on-invalid-keyseq
 419       (its-input-error))
 420
 421      (t
 422       ;; XXX Should make DSYL (instead of VSYL)?
 423       (setq keyseq (concat (its-get-keyseq state) (if (> key 0) (vector key))))
 424       (funcall emit (its-make-VSYL keyseq) state nil)))))
 425
 426 (defvar its-latest-SYL nil
 427   "The latest SYL inserted.")
 428 (defsubst its-update-latest-SYL (syl)
 429   (setq its-latest-SYL syl))
 430
 431 ;; Return CURSOR
 432 (defun its-state-machine-keyseq (keyseq emit &optional eol)
 433   (let ((i 0)
 434         (len (length keyseq))
 435         (syl (its-initial-ISYL))
 436         cursor)
 437     (while (< i len)
 438       (cond
 439        ((numberp (cdr syl))
 440         ;; VSYL - no need looping
 441         (funcall emit
 442                  (its-make-VSYL (concat (car syl) (substring keyseq i)))
 443                  syl nil)
 444         (setq cursor nil
 445               i len))
 446        (t
 447         (setq cursor (its-state-machine syl (aref keyseq i) emit))))
 448       (if (eq cursor 'its-keyseq-test-failed)
 449           (setq i len)
 450         (setq syl (if cursor (its-initial-ISYL) its-latest-SYL)
 451               i (1+ i))))
 452     (if (and eol (not (eq cursor 'its-keyseq-test-failed)))
 453         (its-state-machine syl -1 emit)
 454       cursor)))
 455
 456 (defun its-buffer-ins/del-SYL (newsyl oldsyl cursor)
 457   (if its-setup-fence-before-insert-SYL
 458       (progn
 459         (setq its-setup-fence-before-insert-SYL nil)
 460         (its-setup-fence-mode)))
 461   (let ((inhibit-read-only t))
 462     (its-buffer-delete-SYL oldsyl)
 463     (its-update-latest-SYL newsyl)
 464     (let ((p (point)))
 465       (insert (its-get-output newsyl))
 466       (add-text-properties p (point)
 467                            (list 'its-map its-current-map
 468                                  'its-syl newsyl
 469                                  'egg-lang its-current-language
 470                                  'read-only t
 471                                  'intangible 'its-part-1))
 472       (if its-fence-face
 473           (egg-set-face p (point) (its-get-fence-face)))
 474       (its-set-cursor-status cursor))))
 475
 476 (defun its-buffer-delete-SYL (syl)
 477   (let ((len (length (its-get-output syl))))
 478     (delete-region (- (point) len) (point))))
 479
 480 (defun its-get-next-state (state key)
 481   (let ((kst/t (its-get-kst/t state)))
 482     (and (listp kst/t)
 483          (cdr (assq key (car kst/t))))))
 484
 485 ;; XXX XXX XXX
 486 (defun its-otherwise-match (expr key)
 487   (or (null expr)                       ; <expr>::= NIL means "ANY"
 488       (let ((case-fold-search nil))
 489         (string-match expr (char-to-string key)))))
 490
 491 (defun its-get-otherwise (state key)
 492   (let* ((kst/t (its-get-kst/t state))
 493          (ebl (cdr kst/t))
 494          expr-output-back)
 495       (while ebl
 496         (setq expr-output-back (car ebl))
 497         (let ((expr (its-eob-keyexpr expr-output-back)))
 498           (if (its-otherwise-match expr key)
 499               (setq ebl nil)
 500             (setq ebl (cdr ebl)))))
 501       expr-output-back))
 502
 503 (defun its-keyseq-acceptable-p (keyseq &optional syl eol)
 504   (let ((i 0)
 505         (len (length keyseq))
 506         (its-barf-on-invalid-keyseq 'its-keyseq-test)
 507         (its-latest-SYL nil)
 508         (emit (lambda (nsyl osyl cursor)
 509                 (its-update-latest-SYL nsyl)
 510                 cursor))
 511         (its-current-map its-current-map)
 512         (its-current-select-func its-current-select-func)
 513         (its-current-language its-current-language)
 514         (its-zhuyin its-zhuyin)
 515         (its-previous-select-func its-previous-select-func)
 516         cursor)
 517     (if (null syl)
 518         (setq syl (its-initial-ISYL)))
 519     (while (and syl (< i len))
 520       (setq cursor (its-state-machine syl (aref keyseq i) emit))
 521       (cond
 522        ((eq cursor 'its-keyseq-test-failed)
 523         (setq syl nil))
 524        (cursor
 525         (setq syl (its-initial-ISYL)))
 526        (t
 527         its-latest-SYL))
 528       (setq i (1+ i)))
 529     (if (and syl eol)
 530         (setq cursor (its-state-machine syl -1 emit)))
 531     (not (eq cursor 'its-keyseq-test-failed))))
 532 \f
 533 ;;;
 534 ;;; Name --> map
 535 ;;;
 536 ;;; ITS name: string
 537
 538 (defvar its-map-alist nil)
 539
 540 (defun its-get-map (name)
 541   (assoc name its-map-alist))
 542
 543 (defun its-register-map (map)
 544   (let* ((name (car map))
 545          (place (assoc name its-map-alist)))
 546     (if place
 547         (setcdr place (cdr map))
 548       (setq its-map-alist (cons map its-map-alist)))
 549     map))
 550
 551 (defmacro define-its-state-machine (map name indicator lang doc &rest exprs)
 552   `(progn
 553      (eval-when (eval compile)
 554        (let ((its-current-map (its-new-map ,name ,indicator ,lang)))
 555          ,@exprs
 556          (setq ,map its-current-map)))
 557      (define-its-compiled-map ,map ,doc)))
 558
 559 (defmacro define-its-compiled-map (map doc)
 560   `(defconst ,map ',(symbol-value map) ,doc))
 561
 562 (defmacro define-its-state-machine-append (map &rest exprs)
 563   (append
 564    `(let ((its-current-map ,map)))
 565    exprs
 566    (list `(setq ,map its-current-map))))
 567
 568 ;;
 569 ;; Construct State Machine
 570 ;;
 571 (defun its-defrule (input output &optional back enable-overwrite)
 572   "\e$BF~NO\e(B INPUT \e$B$rG'<1$7\e(B, OUTPUT \e$B$r=PNO$9$k$h$&$K%9%F!<%H%^%7%s$r9=@.$9$k!#\e(B
 573 BACK \e$B$,\e(B(\e$BIi$N\e(B)\e$B@0?t$N;~$O\e(B, OUTPUT \e$B$r=PNO$7$?8e\e(B, BACK \e$B$NJ,\e(B key stroke \e$B$r\e(B
 574 \e$BLa$C$FF0$/$b$N$H$9$k!#JQ495,B'$O$b$C$H$b:G6a$K\e(B its-define-state-machine
 575 \e$B$5$l$?JQ49I=$KEPO?$5$l$k!#\e(B
 576 Return last state."
 577   (let ((state (its-goto-state (substring input 0 -1) nil t))
 578         (key (aref input (1- (length input)))))
 579     (if (and (its-get-next-state state key) (not enable-overwrite))
 580         (error "Duplicated definition (%s)" input)
 581       (its-make-next-state state key input output back))))
 582
 583 (defun its-goto-state (input &optional initial-state build-if-none)
 584   (let ((len (length input))
 585         (i 0)
 586         (state (or initial-state (its-get-start-state its-current-map))))
 587     (while (< i len)
 588       (setq state
 589             (or (its-get-next-state state (aref input i))
 590                 (if build-if-none
 591                     (let ((keyseq (substring input 0 (1+ i))))
 592                       (its-make-next-state state (aref input i) keyseq keyseq))
 593                    (error "No such state (%s)" input)))
 594             i (1+ i)))
 595     state))
 596
 597 (defun its-defoutput (input display)
 598   (let ((state (its-goto-state input)))
 599     (its-set-output state display)))
 600
 601 (defun its-define-otherwise (state otherwise)
 602   (let ((kst (its-get-kst/t state)))
 603     (if kst
 604         (setcdr kst (cons otherwise (cdr kst)))
 605       (its-set-kst state (cons nil (cons otherwise nil))))))
 606
 607 (defconst its-otherwise-back-one
 608   (its-make-class+back nil -1))
 609
 610 (defun its-defrule-otherwise (state output &optional class back)
 611   (let (class+back)
 612     (if (null back)
 613         (setq class+back its-otherwise-back-one)
 614       (setq class+back (its-make-class+back class back)))
 615     (its-define-otherwise state
 616                           (its-make-otherwise output class+back))))
 617
 618 (defun its-defrule* (input output)
 619   (let ((state (its-defrule input output)))
 620     (its-defrule-otherwise state output)))
 621
 622 (defun its-make-next-state (state key keyseq output &optional back)
 623   (let ((next-state (its-new-state output keyseq back))
 624         (kst (its-get-kst/t state)))
 625     (cond
 626      ((null kst)
 627       (its-set-kst state (list (list (cons key next-state)))))
 628      ((consp kst)
 629       (setcar kst (cons (cons key next-state) (car kst))))
 630      (t
 631       (error "Can't make new state after %S" (its-get-keyseq state))))
 632     next-state))
 633
 634 (defmacro its-defrule-select-mode-temporally (input select-func)
 635   `(its-defrule ,input '(its-select-mode-temporally
 636                          ,(intern (concat "its-select-"
 637                                           (symbol-name select-func))))
 638                 t))
 639 \f
 640 ;;;
 641 (defun its-beginning-of-input-buffer ()
 642   (interactive)
 643   (let ((inhibit-read-only t))
 644     (its-input-end)
 645     (if (not (get-text-property (1- (point)) 'its-start))
 646         (let ((begpos (previous-single-property-change (point) 'its-start)))
 647           ;; Make SYLs have property of "part 2"
 648           (put-text-property begpos (point) 'intangible 'its-part-2)
 649           (goto-char begpos)))
 650     (its-put-cursor t)))
 651
 652 (defun its-end-of-input-buffer ()
 653   (interactive)
 654   (let ((inhibit-read-only t))
 655     (its-input-end)
 656     (if (not (get-text-property (point) 'its-end))
 657         (let ((endpos (next-single-property-change (point) 'its-end)))
 658           ;; Make SYLs have property of "part 1"
 659           (put-text-property (point) endpos 'intangible 'its-part-1)
 660           (goto-char endpos)))
 661     (its-put-cursor t)))
 662
 663 (defun its-kill-line (n)
 664   (interactive "p")
 665   (let ((inhibit-read-only t)
 666         (p (point)))
 667     (its-input-end)
 668     (if (> n 0)
 669         (cond
 670          ((get-text-property (1- (point)) 'its-start)
 671           (its-cancel-input))
 672          ((get-text-property (point) 'its-end)
 673           (its-put-cursor t))
 674          (t
 675           (delete-region (next-single-property-change (point) 'its-end)
 676                          (point))
 677           (its-put-cursor t)))
 678       (cond
 679        ((get-text-property (point) 'its-end)
 680         (its-cancel-input))
 681        ((get-text-property (1- (point)) 'its-start)
 682         (its-put-cursor t))
 683        (t
 684         (delete-region (point)
 685                        (previous-single-property-change (point) 'its-start))
 686         (its-put-cursor t))))))
 687
 688 (defun its-cancel-input ()
 689   (interactive)
 690   (let ((inhibit-read-only t))
 691     (delete-region (if (get-text-property (1- (point)) 'its-start)
 692                        (point)
 693                      (previous-single-property-change (1- (point)) 'its-start))
 694                    (if (get-text-property (point) 'its-end)
 695                        (point)
 696                      (next-single-property-change (point) 'its-end)))
 697     (its-put-cursor t)
 698     (its-exit-mode-internal)))
 699
 700 ;; TODO: move in VSYL
 701 (defun its-backward-SYL (n)
 702   (interactive "p")
 703   (let ((inhibit-read-only t)
 704         syl p old-point)
 705     (its-input-end)
 706     (setq syl (get-text-property (1- (point)) 'its-syl)
 707           p (point)
 708           old-point (point))
 709     (while (and syl (> n 0))
 710       (setq p (- p (length (its-get-output syl))))
 711       (setq syl (get-text-property (1- p) 'its-syl))
 712       (setq n (1- n)))
 713     ;; Make SYLs have property of "part 2"
 714     (put-text-property p old-point 'intangible 'its-part-2)
 715     (goto-char p)
 716     (its-put-cursor t)
 717     (if (> n 0)
 718         (signal 'beginning-of-buffer nil))))
 719
 720 ;; TODO: move in VSYL
 721 (defun its-forward-SYL (n)
 722   (interactive "p")
 723   (let ((inhibit-read-only t)
 724         syl p old-point)
 725     (its-input-end)
 726     (setq syl (get-text-property (point) 'its-syl)
 727           p (point)
 728           old-point (point))
 729     (while (and syl (> n 0))
 730       (setq p (+ p (length (its-get-output syl))))
 731       (setq syl (get-text-property p 'its-syl))
 732       (setq n (1- n)))
 733     ;; Make SYLs have property of "part 1"
 734     (put-text-property old-point p 'intangible 'its-part-1)
 735     (goto-char p)
 736     (its-put-cursor t)
 737     (if (> n 0)
 738         (signal 'end-of-buffer nil))))
 739
 740 ;; TODO: handle VSYL.  KILLFLAG
 741 (defun its-delete-SYL (n killflag)
 742   (interactive "p\nP")
 743   (let ((inhibit-read-only t)
 744         syl p)
 745     (its-input-end)
 746     (setq syl (get-text-property (point) 'its-syl)
 747           p (point))
 748     (while (and syl (> n 0))
 749       (setq p (+ p (length (its-get-output syl))))
 750       (setq syl (get-text-property p 'its-syl))
 751       (setq n (1- n)))
 752     (if (> n 0)
 753         (progn
 754           (its-put-cursor t)
 755           (signal 'end-of-buffer nil))
 756       (delete-region (point) p)
 757       (its-put-cursor t)
 758       ;; Check if empty
 759       (if (and (get-text-property (1- (point)) 'its-start)
 760                (get-text-property (1+ (point)) 'its-end))
 761           (its-exit-mode-internal)))))
 762
 763 ;; TODO: killflag
 764 (defun its-delete-backward-SYL (n killflag)
 765   (interactive "p\nP")
 766   (let ((inhibit-read-only t)
 767         (syl (get-text-property (1- (point)) 'its-syl))
 768         (cursor (get-text-property (point) 'its-cursor)))
 769     (if (null syl)
 770         (signal 'beginning-of-buffer nil)
 771       (if (eq cursor t)
 772           (its-delete-backward-SYL-internal n killflag)
 773         (its-delete-backward-within-SYL syl n killflag)))))
 774
 775 ;; TODO: killflag
 776 (defun its-delete-backward-SYL-internal (n killflag)
 777   (let ((syl (get-text-property (1- (point)) 'its-syl))
 778         (p (point)))
 779     (while (and syl (> n 0))
 780       (setq p (- p (length (its-get-output syl))))
 781       (setq syl (get-text-property (1- p) 'its-syl))
 782       (setq n (1- n)))
 783     (if (> n 0)
 784         (signal 'beginning-of-buffer nil)
 785       (delete-region p (1+ (point)))    ; also delete cursor
 786       (its-put-cursor t)
 787       ;; Check if empty
 788       (if (and (get-text-property (1- (point)) 'its-start)
 789                (get-text-property (1+ (point)) 'its-end))
 790           (its-exit-mode-internal)))))
 791
 792 (defvar its-delete-by-keystroke nil)
 793
 794 (defun its-delete-backward-SYL-by-keystroke (n killflag)
 795   (interactive "p\nP")
 796   (let ((inhibit-read-only t)
 797         (its-delete-by-keystroke t))
 798     (its-delete-backward-SYL n killflag)))
 799
 800 ;; TODO: killflag
 801 (defun its-delete-backward-within-SYL (syl n killflag)
 802   (let* ((keyseq (its-get-keyseq-syl syl))
 803          (len (length keyseq))
 804          (p (- (point) (length (its-get-output syl))))
 805          (its-current-map (get-text-property (1- (point)) 'its-map))
 806          (its-current-language (get-text-property (1- (point)) 'egg-lang))
 807          back pp)
 808     (if (< n 0)
 809         (signal 'args-out-of-range (list (- (point) n) (point))))
 810     (if its-delete-by-keystroke
 811       (while (null (or (eq p pp) (its-concrete-DSYL-p syl)))
 812           (setq pp p)
 813           (while (and (setq syl (get-text-property (1- p) 'its-syl))
 814                       (its-DSYL-with-back-p syl)
 815                       (<= (setq back (- (its-get-kst/t syl))) len)
 816                       (> back (- len n))
 817                       (equal (substring (its-get-keyseq syl) (- back))
 818                              (substring keyseq 0 back)))
 819             (setq keyseq (concat (its-get-keyseq-syl syl) keyseq)
 820                   len (length keyseq)
 821                   p (- p (length (its-get-output syl)))))
 822           (if (and (eq p pp) syl (> n len))
 823               (setq n (- n len)
 824                     keyseq (its-get-keyseq-syl syl)
 825                     len (length keyseq)
 826                     p (- p (length (its-get-output syl))))))
 827       (if (and (> n len) (its-concrete-DSYL-p syl))
 828           (setq len 1)))
 829     (if (> n len)
 830         (setq n (- n len)
 831               len 0))
 832     (while (and (> n len) (setq syl (get-text-property (1- p) 'its-syl)))
 833       (setq n (1- n)
 834             p (- p (length (its-get-output syl)))))
 835     (if (> n len)
 836         (signal 'beginning-of-buffer nil))
 837     (delete-region p (point))
 838     (cond
 839      ((> len n)
 840       (its-state-machine-keyseq (substring keyseq 0 (- len n))
 841                                 'its-buffer-ins/del-SYL))
 842      ;; Check if empty
 843      ((and (get-text-property (1- (point)) 'its-start)
 844            (get-text-property (1+ (point)) 'its-end))
 845       (its-exit-mode-internal))
 846      ((and its-delete-by-keystroke
 847            (null (its-concrete-DSYL-p (get-text-property (1- p) 'its-syl))))
 848       (its-set-cursor-status 'its-cursor))
 849      (t
 850       (its-set-cursor-status t)))))
 851
 852 (defun its-transpose-chars (n)
 853   (interactive "p")
 854   (let ((inhibit-read-only t)
 855         (syl (get-text-property (1- (point)) 'its-syl))
 856         (cursor (get-text-property (point) 'its-cursor))
 857         keyseq len)
 858     (cond
 859      ((null syl)
 860       (signal 'beginning-of-buffer nil))
 861      ((eq cursor t)
 862       (if (and (= n 1) (get-text-property (1+ (point)) 'its-end))
 863           (progn
 864             (its-backward-SYL 1)
 865             (setq syl (get-text-property (1- (point)) 'its-syl))
 866             (if (null syl)
 867                 (signal 'beginning-of-buffer nil))))
 868       (its-buffer-delete-SYL syl)
 869       (while (> n 0)
 870         (if (get-text-property (1+ (point)) 'its-end)
 871             (progn
 872               (its-buffer-ins/del-SYL syl nil t)
 873               (signal 'end-of-buffer nil)))
 874         (its-forward-SYL 1)
 875         (setq n (1- n)))
 876       (while (< n 0)
 877         (if (get-text-property (1- (point)) 'its-start)
 878             (progn
 879               (its-buffer-ins/del-SYL syl nil t)
 880               (signal 'beginning-of-buffer nil)))
 881         (its-backward-SYL 1)
 882         (setq n (1+ n)))
 883       (its-buffer-ins/del-SYL syl nil t))
 884      (t
 885       (setq keyseq (its-get-keyseq-syl syl)
 886             len (length keyseq))
 887       (cond
 888        ((or (> n 1) (<= len 1))
 889         (signal 'end-of-buffer nil))
 890        ((>= (- n) len)
 891         (signal 'beginning-of-buffer nil))
 892        (t
 893         (setq n (if (> n 0) (- -1 n) (1- n)))
 894         (setq keyseq (concat (substring keyseq 0 n)
 895                              (substring keyseq -1)
 896                              (substring keyseq n -1)))
 897         (if (and its-barf-on-invalid-keyseq
 898                  (null (its-keyseq-acceptable-p keyseq)))
 899             (its-input-error))
 900         (delete-region (- (point) (length (its-get-output syl))) (point))
 901         (its-state-machine-keyseq keyseq 'its-buffer-ins/del-SYL)))))))
 902
 903 (defun its-yank (&optional arg)
 904   (interactive "*P")
 905   (let ((inhibit-read-only t))
 906     (its-input-end)
 907     (its-put-cursor t)
 908     (yank arg)
 909     (its-setup-yanked-portion (region-beginning) (region-end))))
 910
 911 (defun its-yank-pop (arg)
 912   (interactive "*p")
 913   (let ((inhibit-read-only t))
 914     (its-input-end)
 915     (its-put-cursor t)
 916     (yank-pop arg)
 917     (its-setup-yanked-portion (region-beginning) (region-end))))
 918
 919 (defun its-setup-yanked-portion (start end)
 920   (let ((yank-before (eq (point) end))
 921         (max-sisheng (make-char 'chinese-sisheng 127))
 922         p syl lang)
 923     (remove-text-properties start end '(intangible nil))
 924     (egg-separate-languages start end t)
 925     (goto-char start)
 926     (while (< (point) end)
 927       (setq p (point)
 928             lang (get-text-property p 'egg-lang))
 929       (if (and
 930            (or (equal lang "Chinese-GB") (equal lang "Chinese-CNS"))
 931            (<= (following-char) max-sisheng)
 932            (setq len (egg-chinese-syllable (buffer-substring (point) end))))
 933           (goto-char (+ (point) len))
 934         (forward-char))
 935       (setq syl (buffer-substring-no-properties p (point)))
 936       (put-text-property p (point) 'its-syl (cons syl syl))
 937       (if its-fence-face
 938           (let ((its-current-language (get-text-property p 'egg-lang)))
 939             (egg-set-face p (point) (its-get-fence-face)))))
 940     (if yank-before
 941         (add-text-properties start end '(read-only t intangible its-part-1))
 942       (add-text-properties start end '(read-only t intangible its-part-2))
 943       (delete-region (point) (1+ (point)))
 944       (goto-char start)
 945       (its-put-cursor t))))
 946
 947 ;; Return VOID
 948 (defun its-input-end ()
 949   (let ((cursor (get-text-property (point) 'its-cursor)))
 950     ;; key "END"
 951     (if (null cursor)
 952         (its-input (get-text-property (1- (point)) 'its-syl) -1))
 953     (delete-region (point) (1+ (point)))))
 954
 955 (defun its-exit-mode ()
 956   "Exit ITS mode."
 957   (interactive)
 958   (let ((inhibit-read-only t))
 959     (its-input-end)
 960     (its-put-cursor t)
 961     (its-exit-mode-internal)))
 962
 963 ;; TODO: handle overwrite-mode, insertion-hook, fill...
 964 (defun its-exit-mode-internal (&optional proceed-to-conversion)
 965   (let (start end s e)
 966     (its-select-previous-mode t)
 967     ;; Delete CURSOR
 968     (delete-region (point) (1+ (point)))
 969     ;; Delete open fence
 970     (setq s (if (get-text-property (1- (point)) 'its-start)
 971                 (point)
 972               (previous-single-property-change (point) 'its-start))
 973          start (- s (length its-fence-open)))
 974     (delete-region start s)
 975     ;; Delete close fence
 976     (setq end (if (get-text-property (point) 'its-end)
 977                   (point)
 978                 (next-single-property-change (point) 'its-end))
 979           e (+ end (length its-fence-close)))
 980     (delete-region end e)
 981     (if proceed-to-conversion
 982         (egg-convert-region start end)
 983       ;; Remove all properties
 984       (set-text-properties start end nil)
 985       (egg-do-auto-fill)
 986       (run-hooks 'input-method-after-insert-chunk-hook))))
 987
 988 (defun its-kick-convert-region ()
 989   (interactive)
 990   (let ((inhibit-read-only t))
 991     (its-input-end)
 992     (its-put-cursor t)
 993     (its-exit-mode-internal t)))
 994
 995 (defun its-kick-convert-region-or-self-insert ()
 996   (interactive)
 997   (let ((syl (and (null (get-text-property (point) 'its-cursor))
 998                   (get-text-property (1- (point)) 'its-syl))))
 999     (if (its-keyseq-acceptable-p (vector last-command-char) syl)
1000         (its-self-insert-char)
1001       (its-kick-convert-region))))
1002
1003 (defun its-in-fence-p ()
1004   (eq (get-text-property (point) 'intangible) 'its-part-2))
1005 \f
1006 (defvar its-translation-result "" "")
1007
1008 (defun its-ins/del-SYL-batch (newsyl oldsyl cursor)
1009   (its-update-latest-SYL newsyl)
1010   (if (and newsyl
1011            (consp (cdr newsyl))
1012            (not (its-kst-p (its-get-kst/t newsyl))))
1013       ;; DSYL
1014       (let ((output (its-get-output newsyl))
1015             (oldlen (length its-translation-result)))
1016         (setq its-translation-result (concat its-translation-result output))
1017         (put-text-property oldlen (length its-translation-result)
1018                            'egg-lang its-current-language
1019                            its-translation-result)))
1020   cursor)
1021
1022 (defun its-translate-region (start end)
1023   (interactive "r")
1024   (its-translate-region-internal start end)
1025   (set-text-properties start (point) nil))
1026
1027 (defun its-translate-region-internal (start end)
1028   (setq its-translation-result "")
1029   (goto-char start)
1030   (let ((i 0)
1031         (syl (its-initial-ISYL))
1032         ;; temporally enable DING
1033         (its-barf-on-invalid-keyseq t)
1034         cursor)
1035     (while (< (point) end)
1036       (let ((key (following-char)))
1037         (setq cursor (its-state-machine syl key 'its-ins/del-SYL-batch))
1038         (forward-char 1)
1039         (if cursor
1040             (setq syl (its-initial-ISYL))
1041           (setq syl its-latest-SYL))))
1042     (if (eq syl its-latest-SYL)
1043         (its-state-machine syl -1 'its-ins/del-SYL-batch))
1044     (delete-region start end)
1045     (insert its-translation-result)))
1046 \f
1047 (defun its-set-mode-line-title ()
1048   (let ((title (its-get-indicator its-current-map)))
1049     (setq current-input-method-title (if its-previous-select-func
1050                                          (concat "<" title ">")
1051                                        title))
1052     (force-mode-line-update)))
1053
1054 (defun its-select-mode-temporally (func)
1055   (let ((select-func its-current-select-func))
1056     (funcall func)
1057     (if (null its-previous-select-func)
1058         (setq its-previous-select-func select-func))
1059     (its-set-mode-line-title)))
1060
1061 (defun its-select-previous-mode (&optional quiet)
1062   (interactive)
1063   (if (null its-previous-select-func)
1064       (if (null quiet)
1065           (beep))
1066     (funcall its-previous-select-func)
1067     (setq its-previous-select-func nil)
1068     (its-set-mode-line-title)))
1069
1070 (provide 'its)
1071 ;;; its.el ends here.