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