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   (let ((its-current-map map))
 556     (set map (its-new-map name indicator
 557                           (if (eq (car-safe lang) 'quote) (nth 1 lang) lang)))
 558     (eval (cons 'progn exprs)))
 559   `(defconst ,map ',(symbol-value map) ,doc))
 560
 561 (defmacro define-its-state-machine-append (map &rest exprs)
 562   `(let ((its-current-map ',map))
 563      ,@exprs))
 564
 565 ;;
 566 ;; Construct State Machine
 567 ;;
 568 (defun its-defrule (input output &optional back enable-overwrite)
 569   "\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
 570 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
 571 \e$BLa$C$FF0$/$b$N$H$9$k!#JQ495,B'$O$b$C$H$b:G6a$K\e(B its-define-state-machine
 572 \e$B$5$l$?JQ49I=$KEPO?$5$l$k!#\e(B
 573 Return last state."
 574   (let ((state (its-goto-state input (if enable-overwrite t 'dup-check))))
 575     (its-set-output state output)
 576     (its-set-kst state back)
 577     state))
 578
 579 (defun its-defrule* (input output &optional enable-overwrite)
 580   (let* ((state (its-goto-state input (if enable-overwrite t 'dup-check))))
 581     (its-set-kst state nil)
 582     (its-set-interim-terminal-state state output)
 583     state))
 584
 585 (defvar its-parent-states)
 586
 587 (defun its-goto-state (input &optional build-if-none)
 588   (let ((len (length input))
 589         (i 0)
 590         (state (its-get-start-state (symbol-value its-current-map)))
 591         brand-new next-state key)
 592     (setq its-parent-states nil)
 593     (while (< i len)
 594       (setq its-parent-states (cons state its-parent-states)
 595             key (aref input i)
 596             i (1+ i)
 597             next-state (its-get-next-state state key))
 598       (cond
 599        (next-state
 600         (setq state next-state))
 601        ((null build-if-none)
 602         (error "No such state (%s)" input))
 603        (t
 604         (if (not (or brand-new (= i 1) (its-get-kst/t state)))
 605             (its-set-interim-terminal-state state))
 606         (setq state (its-make-next-state state key
 607                                          (concat (its-get-output state)
 608                                                  (list key)))
 609               brand-new t))))
 610     (if (and (eq build-if-none 'dup-check) (null brand-new))
 611         (error "Duplicated definition (%s)" input))
 612     state))
 613
 614 (defun its-set-interim-terminal-state (state &optional output)
 615   (or output (setq output (its-get-output state)))
 616   (its-make-next-state state -1 output)
 617   (its-defrule-otherwise state output))
 618
 619 (defun its-defoutput (input display)
 620   (let ((state (its-goto-state input)))
 621     (its-set-output state display)))
 622
 623 (defun its-define-otherwise (state otherwise)
 624   (let ((kst (its-get-kst/t state)))
 625     (if kst
 626         (setcdr kst (cons otherwise (cdr kst)))
 627       (its-set-kst state (cons nil (cons otherwise nil))))))
 628
 629 (defconst its-otherwise-back-one
 630   (its-make-class+back nil -1))
 631
 632 (defun its-defrule-otherwise (state output &optional class back)
 633   (let (class+back)
 634     (if (null back)
 635         (setq class+back its-otherwise-back-one)
 636       (setq class+back (its-make-class+back class back)))
 637     (its-define-otherwise state
 638                           (its-make-otherwise output class+back))))
 639
 640 (defun its-make-next-state (state key output &optional back)
 641   (let ((next-state (its-new-state output
 642                                    (concat (its-get-keyseq state)
 643                                            (if (> key 0) (list key)))
 644                                    back))
 645         (kst (its-get-kst/t state)))
 646     (cond
 647      ((null kst)
 648       (its-set-kst state (list (list (cons key next-state)))))
 649      ((consp kst)
 650       (setcar kst (cons (cons key next-state) (car kst))))
 651      (t
 652       (error "Can't make new state after %S" (its-get-keyseq state))))
 653     next-state))
 654
 655 (defmacro its-defrule-select-mode-temporally (input select-func)
 656   `(its-defrule ,input '(its-select-mode-temporally
 657                          ,(intern (concat "its-select-"
 658                                           (symbol-name select-func))))
 659                 t))
 660 \f
 661 ;;;
 662 (defun its-set-part-1 (beg end)
 663   (let ((inhibit-point-motion-hooks t)
 664         (str (buffer-substring beg end)))
 665     (goto-char beg)
 666     (delete-region beg end)
 667     (put-text-property 0 (- end beg) 'intangible 'its-part-1 str)
 668     (insert str)))
 669
 670 (defun its-set-part-2 (beg end)
 671   (let ((inhibit-point-motion-hooks t)
 672         (str (buffer-substring beg end)))
 673     (goto-char beg)
 674     (delete-region beg end)
 675     (put-text-property 0 (- end beg) 'intangible 'its-part-2 str)
 676     (insert str)))
 677
 678 (defun its-beginning-of-input-buffer ()
 679   (interactive)
 680   (let ((inhibit-read-only t))
 681     (its-input-end)
 682     (if (not (get-text-property (1- (point)) 'its-start))
 683         (let ((begpos (previous-single-property-change (point) 'its-start)))
 684           ;; Make SYLs have property of "part 2"
 685           (its-set-part-2 begpos (point))
 686           (goto-char begpos)))
 687     (its-put-cursor t)))
 688
 689 (defun its-end-of-input-buffer ()
 690   (interactive)
 691   (let ((inhibit-read-only t))
 692     (its-input-end)
 693     (if (not (get-text-property (point) 'its-end))
 694         (let ((endpos (next-single-property-change (point) 'its-end)))
 695           ;; Make SYLs have property of "part 1"
 696           (its-set-part-1 (point) endpos)
 697           (goto-char endpos)))
 698     (its-put-cursor t)))
 699
 700 (defun its-kill-line (n)
 701   (interactive "p")
 702   (let ((inhibit-read-only t)
 703         (p (point)))
 704     (its-input-end)
 705     (if (> n 0)
 706         (cond
 707          ((get-text-property (1- (point)) 'its-start)
 708           (its-cancel-input))
 709          ((get-text-property (point) 'its-end)
 710           (its-put-cursor t))
 711          (t
 712           (delete-region (next-single-property-change (point) 'its-end)
 713                          (point))
 714           (its-put-cursor t)))
 715       (cond
 716        ((get-text-property (point) 'its-end)
 717         (its-cancel-input))
 718        ((get-text-property (1- (point)) 'its-start)
 719         (its-put-cursor t))
 720        (t
 721         (delete-region (point)
 722                        (previous-single-property-change (point) 'its-start))
 723         (its-put-cursor t))))))
 724
 725 (defun its-cancel-input ()
 726   (interactive)
 727   (let ((inhibit-read-only t))
 728     (delete-region (if (get-text-property (1- (point)) 'its-start)
 729                        (point)
 730                      (previous-single-property-change (point) 'its-start))
 731                    (if (get-text-property (point) 'its-end)
 732                        (point)
 733                      (next-single-property-change (point) 'its-end)))
 734     (its-put-cursor t)
 735     (its-exit-mode-internal)))
 736
 737 ;; TODO: move in VSYL
 738 (defun its-backward-SYL (n)
 739   (interactive "p")
 740   (let ((inhibit-read-only t)
 741         syl p old-point)
 742     (its-input-end)
 743     (setq syl (get-text-property (1- (point)) 'its-syl)
 744           p (point)
 745           old-point (point))
 746     (while (and syl (> n 0))
 747       (setq p (- p (length (its-get-output syl))))
 748       (setq syl (get-text-property (1- p) 'its-syl))
 749       (setq n (1- n)))
 750     ;; Make SYLs have property of "part 2"
 751     (its-set-part-2 p old-point)
 752     (goto-char p)
 753     (its-put-cursor t)
 754     (if (> n 0)
 755         (signal 'beginning-of-buffer nil))))
 756
 757 ;; TODO: move in VSYL
 758 (defun its-forward-SYL (n)
 759   (interactive "p")
 760   (let ((inhibit-read-only t)
 761         syl p old-point)
 762     (its-input-end)
 763     (setq syl (get-text-property (point) 'its-syl)
 764           p (point)
 765           old-point (point))
 766     (while (and syl (> n 0))
 767       (setq p (+ p (length (its-get-output syl))))
 768       (setq syl (get-text-property p 'its-syl))
 769       (setq n (1- n)))
 770     ;; Make SYLs have property of "part 1"
 771     (its-set-part-1 old-point p)
 772     (goto-char p)
 773     (its-put-cursor t)
 774     (if (> n 0)
 775         (signal 'end-of-buffer nil))))
 776
 777 ;; TODO: handle VSYL.  KILLFLAG
 778 (defun its-delete-SYL (n killflag)
 779   (interactive "p\nP")
 780   (let ((inhibit-read-only t)
 781         syl p)
 782     (its-input-end)
 783     (setq syl (get-text-property (point) 'its-syl)
 784           p (point))
 785     (while (and syl (> n 0))
 786       (setq p (+ p (length (its-get-output syl))))
 787       (setq syl (get-text-property p 'its-syl))
 788       (setq n (1- n)))
 789     (if (> n 0)
 790         (progn
 791           (its-put-cursor t)
 792           (signal 'end-of-buffer nil))
 793       (delete-region (point) p)
 794       (its-put-cursor t)
 795       ;; Check if empty
 796       (if (and (get-text-property (1- (point)) 'its-start)
 797                (get-text-property (1+ (point)) 'its-end))
 798           (its-exit-mode-internal)))))
 799
 800 ;; TODO: killflag
 801 (defun its-delete-backward-SYL (n killflag)
 802   (interactive "p\nP")
 803   (let ((inhibit-read-only t)
 804         (syl (get-text-property (1- (point)) 'its-syl))
 805         (cursor (get-text-property (point) 'its-cursor)))
 806     (if (null syl)
 807         (signal 'beginning-of-buffer nil)
 808       (if (eq cursor t)
 809           (its-delete-backward-SYL-internal n killflag)
 810         (its-delete-backward-within-SYL syl n killflag)))))
 811
 812 ;; TODO: killflag
 813 (defun its-delete-backward-SYL-internal (n killflag)
 814   (let ((syl (get-text-property (1- (point)) 'its-syl))
 815         (p (point)))
 816     (while (and syl (> n 0))
 817       (setq p (- p (length (its-get-output syl))))
 818       (setq syl (get-text-property (1- p) 'its-syl))
 819       (setq n (1- n)))
 820     (if (> n 0)
 821         (signal 'beginning-of-buffer nil)
 822       (delete-region p (1+ (point)))    ; also delete cursor
 823       (its-put-cursor t)
 824       ;; Check if empty
 825       (if (and (get-text-property (1- (point)) 'its-start)
 826                (get-text-property (1+ (point)) 'its-end))
 827           (its-exit-mode-internal)))))
 828
 829 (defvar its-delete-by-keystroke nil)
 830
 831 (defun its-delete-backward-SYL-by-keystroke (n killflag)
 832   (interactive "p\nP")
 833   (let ((inhibit-read-only t)
 834         (its-delete-by-keystroke t))
 835     (its-delete-backward-SYL n killflag)))
 836
 837 ;; TODO: killflag
 838 (defun its-delete-backward-within-SYL (syl n killflag)
 839   (if (let* ((keyseq (its-get-keyseq-syl syl))
 840              (len (length keyseq))
 841              (p (- (point) (length (its-get-output syl))))
 842              (its-current-map (get-text-property (1- (point)) 'its-map))
 843              (its-current-language (get-text-property (1- (point)) 'egg-lang))
 844              back pp)
 845         (if (< n 0)
 846             (signal 'args-out-of-range (list (- (point) n) (point))))
 847         (if its-delete-by-keystroke
 848             (while (null (or (eq p pp) (its-concrete-DSYL-p syl)))
 849               (setq pp p)
 850               (while (and (setq syl (get-text-property (1- p) 'its-syl))
 851                           (its-DSYL-with-back-p syl)
 852                           (<= (setq back (- (its-get-kst/t syl))) len)
 853                           (> back (- len n))
 854                           (equal (substring (its-get-keyseq syl) (- back))
 855                                  (substring keyseq 0 back)))
 856                 (setq keyseq (concat (its-get-keyseq-syl syl) keyseq)
 857                       len (length keyseq)
 858                       p (- p (length (its-get-output syl)))))
 859               (if (and (eq p pp) syl (> n len))
 860                   (setq n (- n len)
 861                         keyseq (its-get-keyseq-syl syl)
 862                         len (length keyseq)
 863                         p (- p (length (its-get-output syl))))))
 864           (if (and (> n len) (its-concrete-DSYL-p syl))
 865               (setq len 1)))
 866         (if (> n len)
 867             (setq n (- n len)
 868                   len 0))
 869         (while (and (> n len) (setq syl (get-text-property (1- p) 'its-syl)))
 870           (setq n (1- n)
 871                 p (- p (length (its-get-output syl)))))
 872         (if (> n len)
 873             (signal 'beginning-of-buffer nil))
 874         (delete-region p (point))
 875         (if (> len n)
 876             (its-state-machine-keyseq (substring keyseq 0 (- len n))
 877                                       'its-buffer-ins/del-SYL)
 878           (its-set-cursor-status
 879            (if (or (null its-delete-by-keystroke)
 880                    (its-concrete-DSYL-p (get-text-property (1- p) 'its-syl)))
 881                t
 882              'its-cursor)))
 883         (and (get-text-property (1- (point)) 'its-start)
 884              (get-text-property (1+ (point)) 'its-end)))
 885       (its-exit-mode-internal)))
 886
 887 (defun its-transpose-chars (n)
 888   (interactive "p")
 889   (let ((inhibit-read-only t)
 890         (syl (get-text-property (1- (point)) 'its-syl))
 891         (cursor (get-text-property (point) 'its-cursor))
 892         keyseq len)
 893     (cond
 894      ((null syl)
 895       (signal 'beginning-of-buffer nil))
 896      ((eq cursor t)
 897       (if (and (= n 1) (get-text-property (1+ (point)) 'its-end))
 898           (progn
 899             (its-backward-SYL 1)
 900             (setq syl (get-text-property (1- (point)) 'its-syl))
 901             (if (null syl)
 902                 (signal 'beginning-of-buffer nil))))
 903       (its-buffer-delete-SYL syl)
 904       (while (> n 0)
 905         (if (get-text-property (1+ (point)) 'its-end)
 906             (progn
 907               (its-buffer-ins/del-SYL syl nil t)
 908               (signal 'end-of-buffer nil)))
 909         (its-forward-SYL 1)
 910         (setq n (1- n)))
 911       (while (< n 0)
 912         (if (get-text-property (1- (point)) 'its-start)
 913             (progn
 914               (its-buffer-ins/del-SYL syl nil t)
 915               (signal 'beginning-of-buffer nil)))
 916         (its-backward-SYL 1)
 917         (setq n (1+ n)))
 918       (its-buffer-ins/del-SYL syl nil t))
 919      (t
 920       (setq keyseq (its-get-keyseq-syl syl)
 921             len (length keyseq))
 922       (cond
 923        ((or (> n 1) (<= len 1))
 924         (signal 'end-of-buffer nil))
 925        ((>= (- n) len)
 926         (signal 'beginning-of-buffer nil))
 927        (t
 928         (setq n (if (> n 0) (- -1 n) (1- n)))
 929         (setq keyseq (concat (substring keyseq 0 n)
 930                              (substring keyseq -1)
 931                              (substring keyseq n -1)))
 932         (if (and its-barf-on-invalid-keyseq
 933                  (null (its-keyseq-acceptable-p keyseq)))
 934             (its-input-error))
 935         (delete-region (- (point) (length (its-get-output syl))) (point))
 936         (its-state-machine-keyseq keyseq 'its-buffer-ins/del-SYL)))))))
 937
 938 (defun its-yank (&optional arg)
 939   (interactive "*P")
 940   (let ((inhibit-read-only t))
 941     (its-input-end)
 942     (its-put-cursor t)
 943     (yank arg)
 944     (its-setup-yanked-portion (region-beginning) (region-end))))
 945
 946 (defun its-yank-pop (arg)
 947   (interactive "*p")
 948   (let ((inhibit-read-only t))
 949     (its-input-end)
 950     (its-put-cursor t)
 951     (yank-pop arg)
 952     (its-setup-yanked-portion (region-beginning) (region-end))))
 953
 954 (defun its-setup-yanked-portion (start end)
 955   (let ((yank-before (eq (point) end))
 956         syl lang source no-prop-source len i j l)
 957     (setq source (buffer-substring start end)
 958           no-prop-source (buffer-substring-no-properties start end)
 959           len (length source))
 960     (remove-text-properties 0 len '(intangible nil) source)
 961     (egg-separate-languages source (get-text-property (1- start) 'egg-lang))
 962     (setq i 0)
 963     (while (< i len)
 964       (setq lang (get-text-property i 'egg-lang source))
 965       (if (and
 966            (or (eq lang 'Chinese-GB) (eq lang 'Chinese-CNS))
 967            (setq l (egg-chinese-syllable source i)))
 968           (setq j (+ i l))
 969         (setq j (+ i (egg-char-bytes (egg-string-to-char-at source i)))))
 970       (setq syl (substring no-prop-source i j))
 971       (put-text-property i j 'its-syl (cons syl syl) source)
 972       (setq i j))
 973     (if its-fence-face
 974         (let (its-current-language)
 975           (setq i 0)
 976           (while (< i len)
 977             (setq j (egg-next-single-property-change i 'egg-lang source len)
 978                   its-current-language (get-text-property i 'egg-lang source))
 979           (egg-set-face i j (its-get-fence-face) source)
 980           (setq i j))))
 981     (delete-region start end)
 982     (if yank-before
 983         (progn
 984           (add-text-properties 0 len '(read-only t intangible its-part-1) source)
 985           (insert source))
 986       (delete-region (point) (1+ (point)))
 987       (add-text-properties 0 len '(read-only t intangible its-part-2) source)
 988       (insert source)
 989       (goto-char start)
 990       (its-put-cursor t))))
 991
 992 ;; Return VOID
 993 (defun its-input-end ()
 994   (let ((cursor (get-text-property (point) 'its-cursor)))
 995     ;; key "END"
 996     (if (null cursor)
 997         (let ((its-current-language (get-text-property (1- (point)) 'egg-lang)))
 998           (its-input (get-text-property (1- (point)) 'its-syl) -1)))
 999     (delete-region (point) (1+ (point)))))
1000
1001 (defun its-exit-mode ()
1002   "Exit ITS mode."
1003   (interactive)
1004   (let ((inhibit-read-only t))
1005     (its-input-end)
1006     (its-put-cursor t)
1007     (its-exit-mode-internal)))
1008
1009 ;; TODO: handle overwrite-mode, insertion-hook, fill...
1010 (defun its-exit-mode-internal (&optional proceed-to-conversion)
1011   (let (start end s e)
1012     (its-select-previous-mode t)
1013     ;; Delete CURSOR
1014     (delete-region (point) (1+ (point)))
1015     ;; Delete open fence
1016     (setq s (if (get-text-property (1- (point)) 'its-start)
1017                 (point)
1018               (previous-single-property-change (point) 'its-start))
1019          start (- s (length its-fence-open)))
1020     (delete-region start s)
1021     ;; Delete close fence
1022     (setq end (if (get-text-property (point) 'its-end)
1023                   (point)
1024                 (next-single-property-change (point) 'its-end))
1025           e (+ end (length its-fence-close)))
1026     (delete-region end e)
1027     (if proceed-to-conversion
1028         (egg-convert-region start end)
1029       ;; Remove all properties
1030       (goto-char start)
1031       (setq s (buffer-substring-no-properties start end))
1032       (delete-region start end)
1033       (insert s)
1034       (egg-do-auto-fill)
1035       (run-hooks 'input-method-after-insert-chunk-hook))))
1036
1037 (defun its-kick-convert-region ()
1038   (interactive)
1039   (let ((inhibit-read-only t))
1040     (its-input-end)
1041     (its-put-cursor t)
1042     (its-exit-mode-internal t)))
1043
1044 (defun its-kick-convert-region-or-self-insert ()
1045   (interactive)
1046   (let ((syl (and (null (get-text-property (point) 'its-cursor))
1047                   (get-text-property (1- (point)) 'its-syl))))
1048     (if (its-keyseq-acceptable-p (vector last-command-char) syl)
1049         (its-self-insert-char)
1050       (its-kick-convert-region))))
1051
1052 (defun its-in-fence-p ()
1053   (eq (get-text-property (point) 'intangible) 'its-part-2))
1054 \f
1055 (defvar its-translation-result "" "")
1056
1057 (defun its-ins/del-SYL-batch (newsyl oldsyl cursor)
1058   (its-update-latest-SYL newsyl)
1059   (if (and newsyl
1060            (consp (cdr newsyl))
1061            (not (its-kst-p (its-get-kst/t newsyl))))
1062       ;; DSYL
1063       (let ((output (its-get-output newsyl))
1064             (oldlen (length its-translation-result)))
1065         (setq its-translation-result (concat its-translation-result output))
1066         (put-text-property oldlen (length its-translation-result)
1067                            'egg-lang its-current-language
1068                            its-translation-result)))
1069   cursor)
1070
1071 (defun its-translate-region (start end)
1072   (interactive "r")
1073   (its-translate-region-internal start end)
1074   (set-text-properties start (point) nil))
1075
1076 (defun its-translate-region-internal (start end)
1077   (setq its-translation-result "")
1078   (goto-char start)
1079   (let ((i 0)
1080         (syl (its-initial-ISYL))
1081         ;; temporally enable DING
1082         (its-barf-on-invalid-keyseq t)
1083         cursor)
1084     (while (< (point) end)
1085       (let ((key (following-char)))
1086         (setq cursor (its-state-machine syl key 'its-ins/del-SYL-batch))
1087         (forward-char 1)
1088         (if cursor
1089             (setq syl (its-initial-ISYL))
1090           (setq syl its-latest-SYL))))
1091     (if (eq syl its-latest-SYL)
1092         (its-state-machine syl -1 'its-ins/del-SYL-batch))
1093     (delete-region start end)
1094     (insert its-translation-result)))
1095 \f
1096 (defun its-set-mode-line-title ()
1097   (let ((title (its-get-indicator (symbol-value its-current-map))))
1098     (setq current-input-method-title (if its-previous-select-func
1099                                          (concat "<" title ">")
1100                                        title))
1101     (force-mode-line-update)))
1102
1103 (defun its-select-mode-temporally (func)
1104   (let ((select-func its-current-select-func))
1105     (funcall func)
1106     (if (null its-previous-select-func)
1107         (setq its-previous-select-func select-func))
1108     (its-set-mode-line-title)))
1109
1110 (defun its-select-previous-mode (&optional quiet)
1111   (interactive)
1112   (if (null its-previous-select-func)
1113       (if (null quiet)
1114           (beep))
1115     (funcall its-previous-select-func)
1116     (setq its-previous-select-func nil)
1117     (its-set-mode-line-title)))
1118
1119 (defun its-mode ()
1120   "\\{its-mode-map}"
1121   ;; dummy function to get docstring
1122   )
1123
1124 (defun its-mode-help-command ()
1125   "Display documentation for ITS mode."
1126   (interactive)
1127   (with-output-to-temp-buffer "*Help*"
1128     (princ "ITS mode:\n")
1129     (princ (documentation 'its-mode))
1130     (help-setup-xref (cons #'help-xref-mode (current-buffer)) (interactive-p))))
1131
1132 (provide 'its)
1133 ;;; its.el ends here.