its.el

   1 ;;; its.el --- Input Translation System AKA "ITS(uDekirunDa!)"
   2
   3 ;; Copyright (C) 1999,2000 PFU LIMITED
   4
   5 ;; Author: NIIBE Yutaka <gniibe@chroot.org>
   6 ;;         KATAYAMA Yoshio <kate@pfu.co.jp>
   7
   8 ;; Maintainer: TOMURA Satoru <tomura@etl.go.jp>
   9
  10 ;; Keywords: mule, multilingual, input method
  11
  12 ;; This file is part of EGG.
  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 (require 'cl)
  35 (require 'egg-edep)
  36
  37 (defgroup its nil
  38   "Input Translation System of Tamagotchy"
  39   :group 'egg)
  40
  41 (defcustom its-enable-fullwidth-alphabet t
  42   "*Enable fullwidth symbol input."
  43   :group 'its :type 'boolean)
  44
  45 (defcustom its-barf-on-invalid-keyseq nil
  46   "*Don't allow invalid key sequence in input buffer, if non-NIL."
  47   :group 'its :type 'boolean)
  48
  49 (defcustom its-delete-by-keystroke nil
  50   "*Delete characters as if cancel input keystroke, if nin-NIL."
  51   :group 'its :type 'boolean)
  52
  53 (defcustom its-fence-invisible nil
  54   "*Make fences invisible, if nin-NIL."
  55   :group 'its :type 'boolean)
  56
  57 (defcustom its-fence-open "|"
  58   "*String of fence start mark. (should not be null string)"
  59   :group 'its :type '(string :valid-regexp ".+"))
  60
  61 (defcustom its-fence-continue "+"
  62   "*String of fence start mark. (should not be null string)"
  63   :group 'its :type '(string :valid-regexp ".+"))
  64
  65 (defcustom its-fence-close "|"
  66   "*String of fence end mark. (should not be null string)"
  67   :group 'its :type '(string :valid-regexp ".+"))
  68
  69 (defcustom its-fence-face nil
  70   "*Face (or alist of languages and faces) of text in fences."
  71   :group 'its
  72   :type '(choice face
  73                  (repeat :tag "Language-Face alist"
  74                          (cons :tag "Language-Face"
  75                                (choice :tag "Language"
  76                                        (const Japanese)
  77                                        (const Chinese-GB)
  78                                        (const Chinese-CNS)
  79                                        (const Korean)
  80                                        (const :tag "Default" t)
  81                                        (symbol :tag "Other"))
  82                                face))))
  83
  84 (defvar its-current-map nil)
  85 (make-variable-buffer-local 'its-current-map)
  86 (put 'its-current-map 'permanent-local t)
  87
  88 (defvar its-current-select-func nil)
  89 (make-variable-buffer-local 'its-current-select-func)
  90 (put 'its-current-select-func 'permanent-local t)
  91
  92 (defvar its-previous-select-func nil)
  93 (make-variable-buffer-local 'its-previous-select-func)
  94 (put 'its-previous-select-func 'permanent-local t)
  95
  96 (defvar its-current-language)
  97 (make-variable-buffer-local 'its-current-language)
  98 (put 'its-current-language 'permanent-local t)
  99 \f
 100 ;; Data structure in ITS
 101 ;; (1) SYL and CURSOR
 102 ;;
 103 ;; "SYL" stands for something like a syllable.
 104 ;;
 105 ;; <SYL> ::= ( <output> . ( <keyseq> . <terminal> ))   ; Determined:   DSYL
 106 ;;        |  <state>                            ; Intermediate: ISYL
 107 ;;        |  ( <output> . <point> )             ; Verbatim:     VSYL
 108 ;;        |  nil                                ; None
 109 ;;
 110 ;; ;<state> ::=
 111 ;; ;          ( <output> . ( <keyseq> . <key-state-table/terminal> ))
 112 ;;
 113 ;; <keyseq> ::= "string" of key sequence
 114 ;; <output> ::= "string"
 115 ;;
 116 ;; <point> ::= integer which specifies point
 117 ;;
 118 ;; <cursor> ::= nil        ; Previous SYL is active (input will go that SYL)
 119 ;;           |  t          ; input makes new SYL.  DEL deletes previous SYL
 120 ;;           |  its-cursor ; DEL breaks previous SYL, input makes new SYL
 121
 122 ;; Data structures in ITS
 123 ;; (2) State machine which recognizes SYL
 124 ;;
 125 ;; <state> ::= ( <output> <keyseq> . <key-state-table/terminal> )
 126 ;;
 127 ;; <key-state-table/terminal> ::= <key-state-table> ; intermediate state
 128 ;;                             |  <terminal>        ; terminal state
 129 ;;
 130 ;; <key-state-table> ::= ( <key-state-alist> . <expr-output-back-list> )
 131 ;; <key-state-alist> ::= ( <key-state> ... )
 132 ;; <key-state> ::= ( <key> . <state> )
 133 ;; <key> ::= Positive INTEGER which specifies KEY STROKE
 134 ;;        |  -1 ; means END of key stroke
 135 ;;
 136 ;; Only applicable for last transition.
 137 ;; <expr-output-back-list> ::= ( (<output> . (<keyexpr> . <howmanyback>))... )
 138 ;; <keyexpr> ::= something like "[a-z]" which specifies class of key.
 139 ;;            |  NIL; means ANY of key (except END of the key stroke)
 140 ;;
 141 ;;
 142 ;; <keyseq> ::= "string"
 143 ;;
 144 ;; <terminal> ::= nil
 145 ;;             |  <howmanyback>
 146 ;;
 147 ;; <howmanyback> ::= integer which specifies how many key strokes we go back
 148 ;;
 149 ;; <output> ::= "string"
 150
 151 ;; Data structure in ITS (3) Map
 152 ;;
 153 ;; <map>         ::= ( <name> <indicator> <language> . <start-state> )
 154 ;; <name>        ::= "string"
 155 ;; <indicator>   ::= "string"
 156 ;; <language>    ::= "string"
 157 ;; <start-state> ::= <state>
 158 ;;
 159 \f
 160 (defsubst its-new-state (output keyseq back)
 161   (cons output (cons keyseq back)))
 162
 163 (defsubst its-new-map (name indicator language)
 164   (cons name (cons indicator (cons language (its-new-state "" "" nil)))))
 165
 166 (defsubst its-get-indicator (map)
 167   (nth 1 map))
 168
 169 (defsubst its-get-language (map)
 170   (nth 2 map))
 171
 172 (defsubst its-get-start-state (map)
 173   (nthcdr 3 map))
 174
 175 (defsubst its-get-kst/t (state)
 176   (cdr (cdr state)))
 177
 178 (defsubst its-set-kst (state kst)
 179   (setcdr (cdr state) kst))
 180
 181 (defsubst its-get-keyseq (state)
 182   (car (cdr state)))
 183
 184 (defsubst its-set-keyseq (state keyseq)
 185   (setcar (cdr state) keyseq))
 186
 187 (defun its-get-keyseq-cooked (state)
 188   (let ((keyseq (its-get-keyseq state))
 189         (back (its-get-kst/t state)))
 190     (if back
 191         (substring keyseq 0 back)
 192       keyseq)))
 193
 194 (defsubst its-kst-p (kst/t)
 195   (not (or (numberp kst/t) (null kst/t))))
 196
 197 (defsubst its-get-output (syl/state)
 198   (car syl/state))
 199
 200 (defsubst its-set-output (state output)
 201   (setcar state output))
 202
 203 (defsubst its-get-keyseq-syl (syl)
 204   (let ((l (cdr syl)))
 205     (cond ((stringp l)                  ; DSYL
 206            l)
 207           ((numberp l)                  ; VSYL
 208            (car syl))
 209           ((numberp (cdr l))
 210            (substring (car l) 0 (cdr l)))
 211           (t
 212            (car l)))))
 213
 214 (defsubst its-eob-keyexpr (eob)
 215   (car (cdr eob)))
 216 (defsubst its-eob-back (eob)
 217   (cdr (cdr eob)))
 218
 219 (defsubst its-make-class+back (class back)
 220   (cons class back))
 221 (defsubst its-make-otherwise (output class+back)
 222   (cons output class+back))
 223
 224 (defsubst its-DSYL-with-back-p (syl)
 225   (and (consp (cdr syl))
 226        (numberp (its-get-kst/t syl))))
 227
 228 (defsubst its-concrete-DSYL-p (syl)
 229   (stringp (cdr syl)))
 230
 231 (defsubst its-make-concrete-DSYL (syl)
 232   (if (consp (cdr syl))
 233       (cons (its-get-output syl) (its-get-keyseq-syl syl))
 234     syl))
 235
 236 ;;
 237 ;;
 238
 239 (require 'its-keydef)
 240
 241 (defvar its-mode-map
 242   (let ((map (make-sparse-keymap))
 243         (i 33))
 244     (define-key map "\C-a" 'its-beginning-of-input-buffer)
 245     (define-key map "\C-b" 'its-backward-SYL)
 246     (define-key map "\C-c" 'its-cancel-input)
 247     (define-key map "\C-d" 'its-delete-SYL)
 248     (define-key map "\C-e" 'its-end-of-input-buffer)
 249     (define-key map "\C-f" 'its-forward-SYL)
 250     (define-key map "\C-g" 'its-select-previous-mode)
 251     (define-key map "\C-]" 'its-cancel-input)
 252     (define-key map "\C-h" 'its-mode-help-command)
 253     (define-key map "\C-k" 'its-kill-line)
 254 ;;    (define-key map "\C-l" 'its-exit-mode)
 255     (define-key map "\C-m" 'its-exit-mode)      ; RET
 256     (define-key map [return] 'its-exit-mode)
 257     (define-key map "\C-t" 'its-transpose-chars)
 258     (define-key map "\C-w" 'its-kick-convert-region)
 259     (define-key map "\C-y" 'its-yank)
 260     (define-key map "\M-y" 'its-yank-pop)
 261     (define-key map [backspace] 'its-delete-backward-SYL)
 262     (define-key map [delete] 'its-delete-backward-SYL)
 263     (define-key map [M-backspace] 'its-delete-backward-SYL-by-keystroke)
 264     (define-key map [M-delete] 'its-delete-backward-SYL-by-keystroke)
 265     (define-key map [right] 'its-forward-SYL)
 266     (define-key map [left] 'its-backward-SYL)
 267     (while (< i 127)
 268       (define-key map (vector i) 'its-self-insert-char)
 269       (setq i (1+ i)))
 270     (define-key map " "    'its-kick-convert-region-or-self-insert)
 271     (define-key map "\177" 'its-delete-backward-SYL)
 272     ;;
 273     (define-key map "\M-p" 'its-previous-map)
 274     (define-key map "\M-n" 'its-next-map)
 275     ;;;(define-key map "\M-h" 'its-hiragana) ; hiragana-region for input-buffer
 276     ;;;(define-key map "\M-k" 'its-katakana)
 277     ;;;(define-key map "\M-<" 'its-hankaku)
 278     ;;;(define-key map "\M->" 'its-zenkaku)
 279     map)
 280   "Keymap for ITS mode.")
 281
 282 (fset 'its-mode-map its-mode-map)
 283
 284 (defconst its-setup-fence-before-insert-SYL nil)
 285
 286 (defun its-get-fence-face (lang)
 287   (if (null (consp its-fence-face))
 288       its-fence-face
 289     (cdr (or (assq lang its-fence-face)
 290              (assq t its-fence-face)))))
 291
 292 (defun its-put-cursor (cursor)
 293   (if (null (eq its-barf-on-invalid-keyseq 'its-keyseq-test))
 294       (let ((p (point)))
 295         (insert "!")
 296         (add-text-properties p (point) (list 'local-map 'its-mode-map
 297                                              'read-only t
 298                                              'invisible t
 299                                              'intangible 'its-part-2
 300                                              'its-cursor cursor))
 301         (goto-char p))))
 302
 303 (defsubst its-set-cursor-status (cursor)
 304   (put-text-property (point) (1+ (point)) 'its-cursor cursor)
 305   cursor)
 306
 307 (defvar its-context nil)
 308
 309 ;;
 310 ;;  +-- START property
 311 ;;  |          --- CURSOR Property
 312 ;;  |         /
 313 ;;  v        v    v-- END Property
 314 ;;  |SYL SYL ^ SYL|
 315 ;;   ^^^ ^^^   ^^^------ SYL Property
 316 ;;  <-------><---->
 317 ;; intangible intangible
 318 ;;     1       2
 319 ;;
 320 (defun its-setup-fence-mode ()
 321   (let ((open-props '(its-start t intangible its-part-1))
 322         (close-props '(rear-nonsticky t its-end t intangible its-part-2))
 323         (p (point)) p1)
 324     (if (or (null (stringp its-fence-open)) (zerop (length its-fence-open))
 325             (null (stringp its-fence-continue)) (zerop (length its-fence-continue))
 326             (null (stringp its-fence-close)) (zerop (length its-fence-close)))
 327         (error "invalid fence"))
 328     ;; Put open-fence before inhibit-read-only to detect read-only
 329     (insert (if its-context its-fence-continue its-fence-open))
 330     (let ((inhibit-read-only t))
 331       (setq p1 (point))
 332       (add-text-properties p p1 open-props)
 333       (if its-context
 334           (put-text-property p p1 'its-context its-context))
 335       (insert its-fence-close)
 336       (add-text-properties p1 (point) close-props)
 337       (if its-fence-invisible
 338           (put-text-property p (point) 'invisible t))
 339       (put-text-property p (point) 'read-only t)
 340       (goto-char p1)
 341       (its-define-select-keys its-mode-map t)
 342       (its-put-cursor t))))
 343
 344 (defun its-start (key context)
 345   (let ((its-setup-fence-before-insert-SYL t)
 346         (its-context context))
 347     (its-input nil key)))
 348
 349 (defun its-restart (str set-prop beginning context)
 350   (let ((its-context context)
 351         p)
 352     (its-setup-fence-mode)
 353     (setq p (point))
 354     (put-text-property 0 (length str) 'intangible 'its-part-1 str)
 355     (insert str)
 356     (if set-prop
 357         (progn
 358           (delete-region (point) (1+ (point)))
 359           (its-setup-yanked-portion p (point))))
 360     (if beginning
 361         (its-beginning-of-input-buffer))))
 362
 363 (defun its-self-insert-char ()
 364   (interactive)
 365   (let ((inhibit-read-only t)
 366         (key last-command-char)
 367         (cursor (get-text-property (point) 'its-cursor))
 368         (syl (get-text-property (1- (point)) 'its-syl)))
 369     (cond
 370      ((or (eq cursor t)
 371           (not (eq (get-text-property (1- (point)) 'its-map) its-current-map)))
 372       (put-text-property (- (point) (length (its-get-output syl))) (point)
 373                          'its-syl (its-make-concrete-DSYL syl))
 374       (setq syl nil))
 375     (cursor
 376      (setq syl nil)))
 377     (its-input syl key)))
 378
 379 (defun its-current-language-length ()
 380   (+ (if (eq (get-text-property (1- (point)) 'egg-lang) its-current-language)
 381          (- (point) (previous-single-property-change (point) 'egg-lang))
 382        0)
 383      (if (eq (get-text-property (1+ (point)) 'egg-lang) its-current-language)
 384          (- (next-single-property-change (1+ (point)) 'egg-lang) (point) 1)
 385        0)))
 386
 387 (defun its-initial-ISYL ()
 388   (its-get-start-state (symbol-value its-current-map)))
 389
 390 (defun its-make-VSYL (keyseq)
 391   (cons keyseq (length keyseq)))
 392
 393 (defun its-input-error ()
 394   (error "Invalid Romaji Sequence"))
 395
 396 (defvar its-stroke-input-alist nil)
 397
 398 (defun its-input (syl key)
 399   (let ((output (car syl))
 400         (k/kk/s (cdr syl))
 401         (stroke (assq its-current-language its-stroke-input-alist)))
 402     (or syl (setq syl (its-initial-ISYL)))
 403     (cond
 404      ((numberp k/kk/s)
 405         ;; k/kk/s is "point in keyseq"
 406         (its-input-to-vsyl syl key k/kk/s output))
 407      ((and (or its-barf-on-invalid-keyseq stroke)
 408            (null (its-keyseq-acceptable-p (vector key) syl)))
 409       ;; signal before altering
 410       (its-input-error))
 411      (t
 412       ;; It's ISYL
 413       (its-state-machine syl key 'its-buffer-ins/del-SYL)
 414       (if (and stroke (>= (its-current-language-length) (cdr stroke)))
 415           (its-kick-convert-region))))))
 416
 417 (defun its-input-to-vsyl (syl key point output)
 418   (if (< key 0)
 419       (its-set-cursor-status t)
 420     (let ((len (length output)))
 421       (if (= len point)
 422           ;; point is at end of VSYL.  Don't need to call state machine.
 423           (its-buffer-ins/del-SYL
 424            (its-make-VSYL (concat output (vector key))) syl nil)
 425         ;; point is at middle of VSYL.
 426         (let ((new-keyseq (concat (substring output 0 point)
 427                                   (vector key)
 428                                   (substring output point))))
 429           (its-state-machine-keyseq new-keyseq 'its-buffer-ins/del-SYL))))))
 430 \f
 431 ;;;
 432 ;;; ITS State Machine
 433 ;;;
 434
 435 (defvar its-disable-special-action nil)
 436
 437 ;; Return CURSOR
 438 (defun its-state-machine (state key emit)
 439   (let ((next-state (its-get-next-state state key))
 440         expr-output-back kst/t output keyseq back)
 441     (cond
 442      ;; proceed to next status
 443      ((and next-state
 444            (not (and its-disable-special-action
 445                      (eq (its-get-kst/t next-state) t))))
 446       (setq kst/t (its-get-kst/t next-state)
 447             output (its-get-output next-state)
 448             keyseq (its-get-keyseq next-state))
 449       (cond
 450        ;; Special actions.
 451        ((eq kst/t t)
 452         (if (stringp output)
 453             (let ((its-current-language t))
 454               (funcall emit (cons output keyseq) state 'its-cursor))
 455           (funcall emit (cons "" keyseq) state 'its-cursor)
 456           (apply (car output) (cdr output))))
 457
 458        ;; Still, it's a intermediate state.
 459        ((its-kst-p kst/t)
 460         (funcall emit next-state state nil))
 461
 462        ;; It's negative integer which specifies how many
 463        ;; characters we go backwards
 464        (kst/t
 465         (funcall emit next-state state 'its-cursor)
 466         (its-state-machine-keyseq (substring keyseq kst/t) emit (< key 0)))
 467
 468        ;; Here we arrive to a terminal state.
 469        ;; Emit a DSYL, and go ahead.
 470        (t
 471         (funcall emit next-state state 'its-cursor))))
 472
 473      ;; push back by otherwise status
 474      ((and (>= key 0)
 475            (setq expr-output-back (its-get-otherwise state key)))
 476       (setq keyseq (concat (its-get-keyseq state) (vector key))
 477             back (its-eob-back expr-output-back))
 478       (funcall emit
 479                (cons (or (its-get-output expr-output-back)
 480                          (its-get-output
 481                           (its-goto-state (substring keyseq 0 back))))
 482                      (cons keyseq back))
 483                state t)
 484       (its-state-machine-keyseq
 485        (substring keyseq back) emit))
 486
 487      ((eq its-barf-on-invalid-keyseq 'its-keyseq-test)
 488       'its-keyseq-test-failed)
 489
 490      ;; No next state for KEY.  It's invalid sequence.
 491      (its-barf-on-invalid-keyseq
 492       (its-input-error))
 493
 494      (t
 495       ;; XXX Should make DSYL (instead of VSYL)?
 496       (setq keyseq (concat (its-get-keyseq state) (if (> key 0) (vector key))))
 497       (funcall emit (its-make-VSYL keyseq) state nil)))))
 498
 499 (defvar its-latest-SYL nil "The latest SYL inserted.")
 500
 501 (defsubst its-update-latest-SYL (syl)
 502   (setq its-latest-SYL syl))
 503
 504 ;; Return CURSOR
 505 (defun its-state-machine-keyseq (keyseq emit &optional eol)
 506   (let ((i 0)
 507         (len (length keyseq))
 508         (syl (its-initial-ISYL))
 509         cursor)
 510     (while (< i len)
 511       (cond
 512        ((numberp (cdr syl))
 513         ;; VSYL - no need looping
 514         (funcall emit
 515                  (its-make-VSYL (concat (car syl) (substring keyseq i)))
 516                  syl nil)
 517         (setq cursor nil
 518               i len))
 519        (t
 520         (setq cursor (its-state-machine syl (aref keyseq i) emit))))
 521       (if (eq cursor 'its-keyseq-test-failed)
 522           (setq i len)
 523         (setq syl (if cursor (its-initial-ISYL) its-latest-SYL)
 524               i (1+ i))))
 525     (if (and eol (not (eq cursor 'its-keyseq-test-failed)))
 526         (its-state-machine syl -1 emit)
 527       cursor)))
 528
 529 (defun its-buffer-ins/del-SYL (newsyl oldsyl cursor)
 530   (if its-setup-fence-before-insert-SYL
 531       (progn
 532         (setq its-setup-fence-before-insert-SYL nil)
 533         (its-setup-fence-mode)))
 534   (let ((inhibit-read-only t)
 535         (output (copy-sequence (its-get-output newsyl)))
 536         (face (its-get-fence-face its-current-language)))
 537     (its-buffer-delete-SYL oldsyl)
 538     (its-update-latest-SYL newsyl)
 539     (add-text-properties 0 (length output)
 540                          (list 'its-map its-current-map
 541                                'its-syl newsyl
 542                                'egg-lang its-current-language
 543                                'read-only t
 544                                'intangible 'its-part-1)
 545                          output)
 546     (if face
 547         (egg-set-face 0 (length output) face output))
 548     (insert output)
 549     (its-set-cursor-status cursor)))
 550
 551 (defun its-buffer-delete-SYL (syl)
 552   (let ((len (length (its-get-output syl))))
 553     (delete-region (- (point) len) (point))))
 554
 555 (defun its-get-next-state (state key)
 556   (let ((kst/t (its-get-kst/t state)))
 557     (and (listp kst/t)
 558          (cdr (assq key (car kst/t))))))
 559
 560 ;; XXX XXX XXX
 561 (defun its-otherwise-match (expr key)
 562   (or (null expr)                       ; <expr>::= NIL means "ANY"
 563       (let ((case-fold-search nil))
 564         (string-match expr (char-to-string key)))))
 565
 566 (defun its-get-otherwise (state key)
 567   (let* ((kst/t (its-get-kst/t state))
 568          (ebl (cdr kst/t))
 569          expr-output-back)
 570       (while ebl
 571         (setq expr-output-back (car ebl))
 572         (let ((expr (its-eob-keyexpr expr-output-back)))
 573           (if (its-otherwise-match expr key)
 574               (setq ebl nil)
 575             (setq ebl (cdr ebl)))))
 576       expr-output-back))
 577
 578 (defun its-keyseq-acceptable-p (keyseq &optional syl eol)
 579   (let ((i 0)
 580         (len (length keyseq))
 581         (its-barf-on-invalid-keyseq 'its-keyseq-test)
 582         (its-latest-SYL nil)
 583         (emit (lambda (nsyl osyl cursor)
 584                 (its-update-latest-SYL nsyl)
 585                 cursor))
 586         (its-current-map its-current-map)
 587         (its-current-select-func its-current-select-func)
 588         (its-current-language its-current-language)
 589         (its-zhuyin its-zhuyin)
 590         (its-previous-select-func its-previous-select-func)
 591         cursor)
 592     (if (null syl)
 593         (setq syl (its-initial-ISYL)))
 594     (if (numberp (cdr syl))
 595         nil
 596       (while (and syl (< i len))
 597         (setq cursor (its-state-machine syl (aref keyseq i) emit))
 598         (cond
 599          ((eq cursor 'its-keyseq-test-failed)
 600           (setq syl nil))
 601          (cursor
 602           (setq syl (its-initial-ISYL)))
 603          (t
 604           its-latest-SYL))
 605         (setq i (1+ i)))
 606       (if (and syl eol)
 607           (setq cursor (its-state-machine syl -1 emit)))
 608       (not (eq cursor 'its-keyseq-test-failed)))))
 609 \f
 610 ;;;
 611 ;;; Name --> map
 612 ;;;
 613 ;;; ITS name: string
 614
 615 (defvar its-map-alist nil)
 616
 617 (defun its-get-map (name)
 618   (assoc name its-map-alist))
 619
 620 (defun its-register-map (map)
 621   (let* ((name (car map))
 622          (place (assoc name its-map-alist)))
 623     (if place
 624         (setcdr place (cdr map))
 625       (setq its-map-alist (cons map its-map-alist)))
 626     map))
 627
 628 (defmacro define-its-state-machine (map name indicator lang doc &rest exprs)
 629   (let ((its-current-map map))
 630     (set map (its-new-map name indicator
 631                           (if (eq (car-safe lang) 'quote) (nth 1 lang) lang)))
 632     (eval (cons 'progn exprs))
 633     (set map (its-map-compaction (symbol-value map))))
 634   `(defconst ,map (its-map-rebuild ',(symbol-value map)) ,doc))
 635
 636 (defmacro define-its-state-machine-append (map &rest exprs)
 637   `(let ((func (lambda () (let ((its-current-map ',map)) ,@exprs)))
 638          (hook ',(intern (concat (symbol-name map) "-hook"))))
 639      (if (null (boundp ',map))
 640          (add-hook hook func t)
 641        (funcall func)
 642        (run-hooks hook)
 643        (setq hook nil))))
 644
 645 ;; Data structure for map compaction
 646 ;;  <node> ::= (<count> <node#> <original node>)   ; atom
 647 ;;          |  (<count> <node#> (<node> . <node>)) ; cons cell
 648 ;;
 649 ;;  <count> ::= integer  ; 0 or negative - usage count
 650 ;;                       ; psotive       - generated common sub-tree
 651 ;;
 652 ;;  <node#> ::= integer  ; subject to compaction
 653 ;;           |  nil      ; not subject to compaction
 654
 655 (defvar its-compaction-enable nil)
 656 (defvar its-compaction-hash-table)
 657 (defvar its-compaction-integer-table)
 658 (defvar its-compaction-counter-1)
 659 (defvar its-compaction-counter-2)
 660 (defvar its-compaction-list)
 661
 662 (defun its-map-compaction (map)
 663   (if its-compaction-enable
 664       (let ((its-compaction-hash-table (make-vector 1000 nil))
 665             (its-compaction-integer-table (make-vector 138 nil))
 666             (its-compaction-counter-1 1)
 667             (its-compaction-counter-2 0)
 668             (its-compaction-list nil))
 669         (its-map-compaction-internal map nil nil)
 670         (cons (vconcat (nreverse its-compaction-list)) map))
 671     map))
 672
 673 (defmacro its-compaction-set-lr (node lr val)
 674   `(if (eq ,lr 'car) (setcar ,node ,val) (setcdr ,node ,val)))
 675
 676 (defmacro its-compaction-new-node ()
 677   '(1- (setq its-compaction-counter-1 (1+ its-compaction-counter-1))))
 678
 679 (defmacro its-compaction-new-cse (node)
 680   `(1- (setq its-compaction-list (cons ,node its-compaction-list)
 681              its-compaction-counter-2 (1+ its-compaction-counter-2))))
 682
 683 (defmacro its-compaction-hash (name node parent lr type)
 684   (if (null type)
 685       `(let ((hash (intern (concat ,@name) its-compaction-hash-table)))
 686          (if (null (boundp hash))
 687              (car (set hash (list* (its-compaction-new-node) ,parent ,lr)))
 688            (setq hash (symbol-value hash))
 689            (if (consp (cdr hash))
 690                (setcdr hash (its-compaction-set-lr
 691                              (cadr hash) (cddr hash)
 692                              (its-compaction-new-cse ,node))))
 693            (its-compaction-set-lr ,parent ,lr (cdr hash))
 694            (car hash)))
 695     `(let ((hash ,(if (eq type 'integer)
 696                       `(intern (concat ,@name) its-compaction-hash-table)
 697                     `(aref its-compaction-integer-table (+ ,node 10)))))
 698        (if (null ,(if (eq type 'integer) '(boundp hash) 'hash))
 699            (setq hash (,@(if (eq type 'integer)
 700                              '(set hash)
 701                            `(aset its-compaction-integer-table (+ ,node 10)))
 702                          (cons (its-compaction-new-node)
 703                                (its-compaction-new-cse ,node))))
 704          ,(if (eq type 'integer) '(setq hash (symbol-value hash))))
 705        (its-compaction-set-lr ,parent ,lr (cdr hash))
 706        (car hash))))
 707
 708 (defun its-map-compaction-internal (map parent lr)
 709   (cond
 710    ((consp map)    (let ((candidate (or (null (stringp (car map))) (cdr map)))
 711                          (l (its-map-compaction-internal (car map) map 'car))
 712                          (r (its-map-compaction-internal (cdr map) map 'cdr)))
 713                      (if (and candidate l r)
 714                          (its-compaction-hash (l " " r) map parent lr nil))))
 715    ((stringp map)  (its-compaction-hash ("STR" map) map parent lr nil))
 716    ((integerp map) (if (and (>= map -10) (< map 128))
 717                        (its-compaction-hash nil map parent lr small-int)
 718                      (its-compaction-hash ("INT" map) map parent lr integer)))
 719    ((null map)     0)))
 720
 721 (defvar its-map-rebuild-subtrees)
 722
 723 (defun its-map-rebuild (map)
 724   (if (vectorp (car map))
 725       (let ((its-map-rebuild-subtrees (car map))
 726             (len (length (car map)))
 727             (i 0)
 728             node)
 729         (while (< i len)
 730           (setq node (aref its-map-rebuild-subtrees i))
 731           (if (consp node)
 732               (its-map-rebuild-1 node))
 733           (setq i (1+ i)))
 734         (its-map-rebuild-1 (cdr map))
 735         (cdr map))
 736     map))
 737
 738 (defun its-map-rebuild-1 (map)
 739   (let (lr)
 740     (while (consp map)
 741       (if (consp (setq lr (car map)))
 742           (its-map-rebuild-1 lr)
 743         (if (integerp lr)
 744             (setcar map (aref its-map-rebuild-subtrees lr))))
 745       (setq lr map
 746             map (cdr map)))
 747     (if (integerp map)
 748           (setcdr lr (aref its-map-rebuild-subtrees map)))))
 749 \f
 750 ;;
 751 ;; Construct State Machine
 752 ;;
 753 (defun its-defrule (input output &optional back enable-overwrite)
 754   "\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
 755 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
 756 \e$BLa$C$FF0$/$b$N$H$9$k!#JQ495,B'$O$b$C$H$b:G6a$K\e(B its-define-state-machine
 757 \e$B$5$l$?JQ49I=$KEPO?$5$l$k!#\e(B
 758 Return last state."
 759   (let ((state (its-goto-state input (if enable-overwrite t 'dup-check))))
 760     (its-set-output state output)
 761     (its-set-kst state back)
 762     state))
 763
 764 (defun its-defrule* (input output &optional interim-output enable-overwrite)
 765   (let* ((state (its-goto-state input (if enable-overwrite t 'dup-check))))
 766     (its-set-kst state nil)
 767     (its-set-interim-terminal-state state output)
 768     (if interim-output
 769         (its-set-output state interim-output))
 770     state))
 771
 772 (defvar its-parent-states)
 773
 774 (defun its-goto-state (input &optional build-if-none)
 775   (let ((len (length input))
 776         (i 0)
 777         (state (its-initial-ISYL))
 778         brand-new next-state key)
 779     (setq its-parent-states nil)
 780     (while (< i len)
 781       (setq its-parent-states (cons state its-parent-states)
 782             key (aref input i)
 783             i (1+ i)
 784             next-state (its-get-next-state state key))
 785       (cond
 786        (next-state
 787         (setq state next-state))
 788        ((null build-if-none)
 789         (error "No such state (%s)" input))
 790        (t
 791         (if (not (or brand-new (= i 1) (its-get-kst/t state)))
 792             (its-set-interim-terminal-state state))
 793         (setq state (its-make-next-state state key
 794                                          (concat (its-get-output state)
 795                                                  (list key)))
 796               brand-new t))))
 797     (if (and (eq build-if-none 'dup-check) (null brand-new))
 798         (error "Duplicated definition (%s)" input))
 799     state))
 800
 801 (defun its-set-interim-terminal-state (state &optional output)
 802   (its-make-next-state state -1 (or output (its-get-output state)))
 803   (its-defrule-otherwise state output))
 804
 805 (defun its-defoutput (input display)
 806   (let ((state (its-goto-state input)))
 807     (its-set-output state display)))
 808
 809 (defun its-define-otherwise (state otherwise)
 810   (let ((kst (its-get-kst/t state)))
 811     (if kst
 812         (setcdr kst (cons otherwise (cdr kst)))
 813       (its-set-kst state (cons nil (cons otherwise nil))))))
 814
 815 (defun its-defrule-otherwise (state output &optional class back)
 816   (its-define-otherwise
 817    state
 818    (its-make-otherwise output (its-make-class+back class (or back -1)))))
 819
 820 (defun its-make-next-state (state key output &optional back)
 821   (let ((next-state (its-new-state output
 822                                    (concat (its-get-keyseq state)
 823                                            (if (> key 0) (list key)))
 824                                    back))
 825         (kst (its-get-kst/t state)))
 826     (cond
 827      ((null kst)
 828       (its-set-kst state (list (list (cons key next-state)))))
 829      ((consp kst)
 830       (setcar kst (cons (cons key next-state) (car kst))))
 831      (t
 832       (error "Can't make new state after %S" (its-get-keyseq state))))
 833     next-state))
 834
 835 (defmacro its-defrule-select-mode-temporally (input select-func)
 836   `(its-defrule ,input '(its-select-mode-temporally
 837                          ,(intern (concat "its-select-"
 838                                           (symbol-name select-func))))
 839                 t))
 840 \f
 841 ;;;
 842 (defun its-set-part-1 (beg end)
 843   (let ((inhibit-point-motion-hooks t)
 844         (str (buffer-substring beg end)))
 845     (goto-char beg)
 846     (delete-region beg end)
 847     (put-text-property 0 (- end beg) 'intangible 'its-part-1 str)
 848     (insert str)))
 849
 850 (defun its-set-part-2 (beg end)
 851   (let ((inhibit-point-motion-hooks t)
 852         (str (buffer-substring beg end)))
 853     (goto-char beg)
 854     (delete-region beg end)
 855     (put-text-property 0 (- end beg) 'intangible 'its-part-2 str)
 856     (insert str)))
 857
 858 (defun its-beginning-of-input-buffer ()
 859   (interactive)
 860   (let ((inhibit-read-only t))
 861     (its-input-end)
 862     (if (not (get-text-property (1- (point)) 'its-start))
 863         (let ((begpos (previous-single-property-change (point) 'its-start)))
 864           ;; Make SYLs have property of "part 2"
 865           (its-set-part-2 begpos (point))
 866           (goto-char begpos)))
 867     (its-put-cursor t)))
 868
 869 (defun its-end-of-input-buffer ()
 870   (interactive)
 871   (let ((inhibit-read-only t))
 872     (its-input-end)
 873     (if (not (get-text-property (point) 'its-end))
 874         (let ((endpos (next-single-property-change (point) 'its-end)))
 875           ;; Make SYLs have property of "part 1"
 876           (its-set-part-1 (point) endpos)
 877           (goto-char endpos)))
 878     (its-put-cursor t)))
 879
 880 (defun its-kill-line (n)
 881   (interactive "p")
 882   (let ((inhibit-read-only t)
 883         (p (point)))
 884     (its-input-end)
 885     (if (> n 0)
 886         (cond
 887          ((get-text-property (1- (point)) 'its-start)
 888           (its-cancel-input))
 889          ((get-text-property (point) 'its-end)
 890           (its-put-cursor t))
 891          (t
 892           (delete-region (next-single-property-change (point) 'its-end)
 893                          (point))
 894           (its-put-cursor t)))
 895       (cond
 896        ((get-text-property (point) 'its-end)
 897         (its-cancel-input))
 898        ((get-text-property (1- (point)) 'its-start)
 899         (its-put-cursor t))
 900        (t
 901         (delete-region (point)
 902                        (previous-single-property-change (point) 'its-start))
 903         (its-put-cursor t))))))
 904
 905 (defun its-cancel-input ()
 906   (interactive)
 907   (let ((inhibit-read-only t))
 908     (delete-region (if (get-text-property (1- (point)) 'its-start)
 909                        (point)
 910                      (previous-single-property-change (point) 'its-start))
 911                    (if (get-text-property (point) 'its-end)
 912                        (point)
 913                      (next-single-property-change (point) 'its-end)))
 914     (its-put-cursor t)
 915     (its-exit-mode-internal)))
 916
 917 ;; TODO: move in VSYL
 918 (defun its-backward-SYL (n)
 919   (interactive "p")
 920   (let ((inhibit-read-only t)
 921         syl p old-point)
 922     (its-input-end)
 923     (setq syl (get-text-property (1- (point)) 'its-syl)
 924           p (point)
 925           old-point (point))
 926     (while (and syl (> n 0))
 927       (setq p (- p (length (its-get-output syl))))
 928       (setq syl (get-text-property (1- p) 'its-syl))
 929       (setq n (1- n)))
 930     ;; Make SYLs have property of "part 2"
 931     (its-set-part-2 p old-point)
 932     (goto-char p)
 933     (its-put-cursor t)
 934     (if (> n 0)
 935         (signal 'beginning-of-buffer nil))))
 936
 937 ;; TODO: move in VSYL
 938 (defun its-forward-SYL (n)
 939   (interactive "p")
 940   (let ((inhibit-read-only t)
 941         syl p old-point)
 942     (its-input-end)
 943     (setq syl (get-text-property (point) 'its-syl)
 944           p (point)
 945           old-point (point))
 946     (while (and syl (> n 0))
 947       (setq p (+ p (length (its-get-output syl))))
 948       (setq syl (get-text-property p 'its-syl))
 949       (setq n (1- n)))
 950     ;; Make SYLs have property of "part 1"
 951     (its-set-part-1 old-point p)
 952     (goto-char p)
 953     (its-put-cursor t)
 954     (if (> n 0)
 955         (signal 'end-of-buffer nil))))
 956
 957 ;; TODO: handle VSYL.  KILLFLAG
 958 (defun its-delete-SYL (n killflag)
 959   (interactive "p\nP")
 960   (let ((inhibit-read-only t)
 961         syl p)
 962     (its-input-end)
 963     (setq syl (get-text-property (point) 'its-syl)
 964           p (point))
 965     (while (and syl (> n 0))
 966       (setq p (+ p (length (its-get-output syl))))
 967       (setq syl (get-text-property p 'its-syl))
 968       (setq n (1- n)))
 969     (if (> n 0)
 970         (progn
 971           (its-put-cursor t)
 972           (signal 'end-of-buffer nil))
 973       (delete-region (point) p)
 974       (its-put-cursor t)
 975       (its-exit-mode-if-empty))))
 976
 977 ;; TODO: killflag
 978 (defun its-delete-backward-SYL (n killflag)
 979   (interactive "p\nP")
 980   (let ((inhibit-read-only t)
 981         (syl (get-text-property (1- (point)) 'its-syl))
 982         (cursor (get-text-property (point) 'its-cursor)))
 983     (if (null syl)
 984         (signal 'beginning-of-buffer nil)
 985       (if (eq cursor t)
 986           (its-delete-backward-SYL-internal n killflag)
 987         (its-delete-backward-within-SYL syl n killflag)))))
 988
 989 ;; TODO: killflag
 990 (defun its-delete-backward-SYL-internal (n killflag)
 991   (let ((syl (get-text-property (1- (point)) 'its-syl))
 992         (p (point)))
 993     (while (and syl (> n 0))
 994       (setq p (- p (length (its-get-output syl))))
 995       (setq syl (get-text-property (1- p) 'its-syl))
 996       (setq n (1- n)))
 997     (if (> n 0)
 998         (signal 'beginning-of-buffer nil)
 999       (delete-region p (1+ (point)))    ; also delete cursor
1000       (its-put-cursor t)
1001       (its-exit-mode-if-empty))))
1002
1003 (defun its-delete-backward-SYL-by-keystroke (n killflag)
1004   (interactive "p\nP")
1005   (let ((inhibit-read-only t)
1006         (its-delete-by-keystroke t))
1007     (its-delete-backward-SYL n killflag)))
1008
1009 ;; TODO: killflag
1010 (defun its-delete-backward-within-SYL (syl n killflag)
1011   (let* ((keyseq (its-get-keyseq-syl syl))
1012          (len (length keyseq))
1013          (p (- (point) (length (its-get-output syl))))
1014          (its-current-map (get-text-property (1- (point)) 'its-map))
1015          (its-current-language (get-text-property (1- (point)) 'egg-lang))
1016          back pp)
1017     (if (< n 0)
1018         (signal 'args-out-of-range (list (- (point) n) (point))))
1019     (if its-delete-by-keystroke
1020         (while (null (or (eq p pp) (its-concrete-DSYL-p syl)))
1021           (setq pp p)
1022           (while (and (setq syl (get-text-property (1- p) 'its-syl))
1023                       (its-DSYL-with-back-p syl)
1024                       (<= (setq back (- (its-get-kst/t syl))) len)
1025                       (> back (- len n))
1026                       (equal (substring (its-get-keyseq syl) (- back))
1027                              (substring keyseq 0 back)))
1028             (setq keyseq (concat (its-get-keyseq-syl syl) keyseq)
1029                   len (length keyseq)
1030                   p (- p (length (its-get-output syl)))))
1031           (if (and (eq p pp) syl (> n len))
1032               (setq n (- n len)
1033                     keyseq (its-get-keyseq-syl syl)
1034                     len (length keyseq)
1035                     p (- p (length (its-get-output syl))))))
1036       (if (and (> n len) (its-concrete-DSYL-p syl))
1037           (setq len 1)))
1038     (if (> n len)
1039         (setq n (- n len)
1040               len 0))
1041     (while (and (> n len) (setq syl (get-text-property (1- p) 'its-syl)))
1042       (setq n (1- n)
1043             p (- p (length (its-get-output syl)))))
1044     (if (> n len)
1045         (signal 'beginning-of-buffer nil))
1046     (delete-region p (point))
1047     (if (> len n)
1048         (its-state-machine-keyseq (substring keyseq 0 (- len n))
1049                                   'its-buffer-ins/del-SYL)
1050       (its-set-cursor-status
1051        (if (or (null its-delete-by-keystroke)
1052                (its-concrete-DSYL-p (get-text-property (1- p) 'its-syl)))
1053            t
1054          'its-cursor))))
1055   ;; exit its mode after unbind variables
1056   (its-exit-mode-if-empty))
1057
1058 (defun its-transpose-chars (n)
1059   (interactive "p")
1060   (let ((inhibit-read-only t)
1061         (syl (get-text-property (1- (point)) 'its-syl))
1062         (cursor (get-text-property (point) 'its-cursor))
1063         keyseq len)
1064     (cond
1065      ((null syl)
1066       (signal 'beginning-of-buffer nil))
1067      ((eq cursor t)
1068       (if (and (= n 1) (get-text-property (1+ (point)) 'its-end))
1069           (progn
1070             (its-backward-SYL 1)
1071             (setq syl (get-text-property (1- (point)) 'its-syl))
1072             (if (null syl)
1073                 (signal 'beginning-of-buffer nil))))
1074       (its-buffer-delete-SYL syl)
1075       (while (> n 0)
1076         (if (get-text-property (1+ (point)) 'its-end)
1077             (progn
1078               (its-buffer-ins/del-SYL syl nil t)
1079               (signal 'end-of-buffer nil)))
1080         (its-forward-SYL 1)
1081         (setq n (1- n)))
1082       (while (< n 0)
1083         (if (get-text-property (1- (point)) 'its-start)
1084             (progn
1085               (its-buffer-ins/del-SYL syl nil t)
1086               (signal 'beginning-of-buffer nil)))
1087         (its-backward-SYL 1)
1088         (setq n (1+ n)))
1089       (its-buffer-ins/del-SYL syl nil t))
1090      (t
1091       (setq keyseq (its-get-keyseq-syl syl)
1092             len (length keyseq))
1093       (cond
1094        ((or (> n 1) (<= len 1))
1095         (signal 'end-of-buffer nil))
1096        ((>= (- n) len)
1097         (signal 'beginning-of-buffer nil))
1098        (t
1099         (setq n (if (> n 0) (- -1 n) (1- n)))
1100         (setq keyseq (concat (substring keyseq 0 n)
1101                              (substring keyseq -1)
1102                              (substring keyseq n -1)))
1103         (if (and its-barf-on-invalid-keyseq
1104                  (null (its-keyseq-acceptable-p keyseq)))
1105             (its-input-error))
1106         (delete-region (- (point) (length (its-get-output syl))) (point))
1107         (its-state-machine-keyseq keyseq 'its-buffer-ins/del-SYL)))))))
1108
1109 (defun its-yank (&optional arg)
1110   (interactive "*P")
1111   (let ((inhibit-read-only t))
1112     (its-input-end)
1113     (yank arg)
1114     (its-setup-yanked-portion (region-beginning) (region-end))))
1115
1116 (defun its-yank-pop (arg)
1117   (interactive "*p")
1118   (let ((inhibit-read-only t))
1119     (its-input-end)
1120     (yank-pop arg)
1121     (its-setup-yanked-portion (region-beginning) (region-end))))
1122
1123 (defun its-setup-yanked-portion (start end)
1124   (let ((yank-before (eq (point) end))
1125         syl face lang source no-prop-source len i j l)
1126     (setq source (buffer-substring start end)
1127           no-prop-source (buffer-substring-no-properties start end)
1128           len (length source))
1129     (remove-text-properties 0 len '(intangible nil) source)
1130     (egg-separate-languages source (get-text-property (1- start) 'egg-lang))
1131     (setq i 0)
1132     (while (< i len)
1133       (setq lang (get-text-property i 'egg-lang source))
1134       (if (and
1135            (or (eq lang 'Chinese-GB) (eq lang 'Chinese-CNS))
1136            (setq l (egg-chinese-syllable source i)))
1137           (setq j (+ i l))
1138         (setq j (+ i (egg-char-bytes (egg-string-to-char-at source i)))))
1139       (setq syl (substring no-prop-source i j))
1140       (put-text-property i j 'its-syl (cons syl syl) source)
1141       (setq i j))
1142     (if its-fence-face
1143         (progn
1144           (setq i 0)
1145           (while (< i len)
1146             (setq j (egg-next-single-property-change i 'egg-lang source len)
1147                   face (its-get-fence-face
1148                         (get-text-property i 'egg-lang source)))
1149             (if face
1150                 (egg-set-face i j face source))
1151             (setq i j))))
1152     (delete-region start end)
1153     (if yank-before
1154         (progn
1155           (add-text-properties 0 len '(read-only t intangible its-part-1) source)
1156           (insert source))
1157       (add-text-properties 0 len '(read-only t intangible its-part-2) source)
1158       (insert source)
1159       (set-marker (mark-marker) (point) (current-buffer))
1160       (goto-char start))
1161     (its-put-cursor t)))
1162
1163 ;; Return VOID
1164 (defun its-input-end ()
1165   (if (null (eq its-barf-on-invalid-keyseq 'its-keyseq-test))
1166       (let ((cursor (get-text-property (point) 'its-cursor)))
1167         ;; key "END"
1168         (if (null cursor)
1169             (let ((its-current-language (get-text-property (1- (point))
1170                                                            'egg-lang)))
1171               (its-input (get-text-property (1- (point)) 'its-syl) -1)))
1172         (delete-region (point) (1+ (point))))))
1173
1174 (defun its-exit-mode ()
1175   "Exit ITS mode."
1176   (interactive)
1177   (if (its-in-fence-p)
1178       (let ((inhibit-read-only t))
1179         (its-input-end)
1180         (its-put-cursor t)
1181         (its-exit-mode-internal))
1182     (its-select-previous-mode t)))
1183
1184 (defun its-exit-mode-if-empty ()
1185   (and (get-text-property (1- (point)) 'its-start)
1186        (get-text-property (1+ (point)) 'its-end)
1187        (its-exit-mode-internal)))
1188
1189 ;; TODO: handle overwrite-mode, insertion-hook, fill...
1190 (defun its-exit-mode-internal (&optional proceed-to-conversion n)
1191   (let (start end s context)
1192     (its-select-previous-mode t)
1193     ;; Delete CURSOR
1194     (delete-region (point) (1+ (point)))
1195     ;; Delete open fence
1196     (setq s (if (get-text-property (1- (point)) 'its-start)
1197                 (point)
1198               (previous-single-property-change (point) 'its-start))
1199          start (previous-single-property-change s 'its-start nil (point-min))
1200          context (get-text-property start 'its-context))
1201     (delete-region start s)
1202     ;; Delete close fence
1203     (setq end (if (get-text-property (point) 'its-end)
1204                   (point)
1205                 (next-single-property-change (point) 'its-end)))
1206     (delete-region end
1207                    (next-single-property-change end 'its-end nil (point-max)))
1208     (if proceed-to-conversion
1209         (egg-convert-region start end context n)
1210       ;; Remove all properties
1211       (goto-char start)
1212       (insert (prog1
1213                   (buffer-substring-no-properties start end)
1214                 (delete-region start end)))
1215       (egg-do-auto-fill)
1216       (run-hooks 'input-method-after-insert-chunk-hook))))
1217
1218 (defun its-kick-convert-region (&optional n)
1219   (interactive "P")
1220   (let ((inhibit-read-only t))
1221     (its-input-end)
1222     (its-put-cursor t)
1223     (its-exit-mode-internal t n)))
1224
1225 (defun its-kick-convert-region-or-self-insert (&optional n)
1226   (interactive "P")
1227   (let ((syl (and (null (get-text-property (point) 'its-cursor))
1228                   (get-text-property (1- (point)) 'its-syl))))
1229     (if (its-keyseq-acceptable-p (vector last-command-char) syl)
1230         (its-self-insert-char)
1231       (its-kick-convert-region n))))
1232
1233 (defun its-in-fence-p ()
1234   (eq (get-text-property (point) 'intangible) 'its-part-2))
1235 \f
1236 (defvar its-translation-result "" "")
1237
1238 (defun its-ins/del-SYL-batch (newsyl oldsyl cursor)
1239   (its-update-latest-SYL newsyl)
1240   (if (and newsyl
1241            (consp (cdr newsyl))
1242            (not (its-kst-p (its-get-kst/t newsyl))))
1243       ;; DSYL
1244       (let ((output (its-get-output newsyl))
1245             (oldlen (length its-translation-result)))
1246         (setq its-translation-result (concat its-translation-result output))
1247         (put-text-property oldlen (length its-translation-result)
1248                            'egg-lang its-current-language
1249                            its-translation-result)))
1250   cursor)
1251
1252 (defun its-translate-region (start end)
1253   (interactive "r")
1254   (its-translate-region-internal start end)
1255   (set-text-properties start (point) nil))
1256
1257 (defun its-translate-region-internal (start end)
1258   (setq its-translation-result "")
1259   (goto-char start)
1260   (let ((i 0)
1261         (syl (its-initial-ISYL))
1262         ;; temporally enable DING
1263         (its-barf-on-invalid-keyseq t)
1264         cursor)
1265     (while (< (point) end)
1266       (let ((key (following-char)))
1267         (setq cursor (its-state-machine syl key 'its-ins/del-SYL-batch))
1268         (forward-char 1)
1269         (if cursor
1270             (setq syl (its-initial-ISYL))
1271           (setq syl its-latest-SYL))))
1272     (if (eq syl its-latest-SYL)
1273         (its-state-machine syl -1 'its-ins/del-SYL-batch))
1274     (delete-region start end)
1275     (insert its-translation-result)))
1276 \f
1277 (defun its-set-mode-line-title ()
1278   (let ((title (its-get-indicator (symbol-value its-current-map))))
1279     (setq current-input-method-title (if its-previous-select-func
1280                                          (concat "<" title ">")
1281                                        title))
1282     (force-mode-line-update)))
1283
1284 (defun its-select-mode-temporally (func)
1285   (let ((select-func its-current-select-func))
1286     (let ((its-previous-select-func t))
1287       (funcall func))
1288     (if (null its-previous-select-func)
1289         (setq its-previous-select-func select-func))
1290     (its-set-mode-line-title)))
1291
1292 (defun its-select-previous-mode (&optional quiet)
1293   (interactive)
1294   (if (null its-previous-select-func)
1295       (if (null quiet)
1296           (beep))
1297     (funcall its-previous-select-func)
1298     (setq its-previous-select-func nil)
1299     (its-set-mode-line-title)))
1300
1301 (defun its-set-stroke-input (alist)
1302   (let ((a alist))
1303     (while a
1304       (setq its-stroke-input-alist
1305             (delq (assq (caar a) its-stroke-input-alist)
1306                   its-stroke-input-alist))
1307       (setq a (cdr a)))
1308     (setq its-stroke-input-alist
1309           (append alist its-stroke-input-alist))))
1310
1311 ;;; its-hiragana : hiragana-region for input-buffer
1312
1313 ;;; its-katakana : katanaka-region for input-buffer
1314
1315 (defun its-mode ()
1316   "\\{its-mode-map}"
1317   ;; dummy function to get docstring
1318   )
1319
1320 (defun its-mode-help-command ()
1321   "Display documentation for ITS mode."
1322   (interactive)
1323   (with-output-to-temp-buffer "*Help*"
1324     (princ "ITS mode:\n")
1325     (princ (documentation 'its-mode))
1326     (help-setup-xref (cons #'help-xref-mode (current-buffer)) (interactive-p))))
1327
1328 (provide 'its)
1329 ;;; its.el ends here.