(require 'cl)
+(defvar its-current-map nil)
+(make-variable-buffer-local 'its-current-map)
+(put 'its-current-map 'permanent-local t)
+
+(defvar its-current-select-func nil)
+(make-variable-buffer-local 'its-current-select-func)
+(put 'its-current-select-func 'permanent-local t)
+
+(defvar its-previous-select-func nil)
+(make-variable-buffer-local 'its-previous-select-func)
+(put 'its-previous-select-func 'permanent-local t)
+
(defvar its-current-language)
(make-variable-buffer-local 'its-current-language)
+(put 'its-current-language 'permanent-local t)
\f
;; Data structure in ITS
;; (1) SYL and CURSOR
;;
;;
-(require 'its-keydef)
+(eval-when (eval load compile)
+ (require 'its-keydef))
(defvar its-mode-map
(let ((map (make-sparse-keymap))
(i 33))
(define-key map "\C-a" 'its-beginning-of-input-buffer)
(define-key map "\C-b" 'its-backward-SYL)
+ (define-key map "\C-c" 'its-cancel-input)
(define-key map "\C-d" 'its-delete-SYL)
(define-key map "\C-e" 'its-end-of-input-buffer)
(define-key map "\C-f" 'its-forward-SYL)
+ (define-key map "\C-g" 'its-select-previous-mode)
(define-key map "\C-]" 'its-cancel-input)
(define-key map "\C-h" 'its-mode-help-command)
(define-key map "\C-k" 'its-kill-line)
(define-key map "\C-m" 'its-exit-mode) ; RET
(define-key map [return] 'its-exit-mode)
(define-key map "\C-t" 'its-transpose-chars)
+ (define-key map "\C-w" 'its-kick-convert-region)
+ (define-key map "\C-y" 'its-yank)
+ (define-key map "\M-y" 'its-yank-pop)
(define-key map [backspace] 'its-delete-backward-SYL)
(define-key map [delete] 'its-delete-backward-SYL)
(define-key map [M-backspace] 'its-delete-backward-SYL-by-keystroke)
(define-key map [M-delete] 'its-delete-backward-SYL-by-keystroke)
(define-key map [right] 'its-forward-SYL)
(define-key map [left] 'its-backward-SYL)
- (define-key map "\C-\\" 'its-exit-mode-off-input-method)
(while (< i 127)
(define-key map (vector i) 'its-self-insert-char)
(setq i (1+ i)))
- (define-key map " " 'its-kick-convert-region)
+ (define-key map " " 'its-kick-convert-region-or-self-insert)
(define-key map "\177" 'its-delete-backward-SYL)
;;
(define-key map "\M-p" 'its-previous-map)
(define-key map "\M-k" 'its-katakana)
(define-key map "\M-<" 'its-hankaku)
(define-key map "\M->" 'its-zenkaku)
-; (its-define-select-keys map t)
+ (its-define-select-keys map t)
map)
"Keymap for ITS mode.")
-(defvar its-fence-open "|" "*\e$B%U%'%s%9$N;OE@$r<($9J8;zNs\e(B (1 \e$BJ8;z\e(B)")
-(defvar its-fence-close "|" "*\e$B%U%'%s%9$N=*E@$r<($9J8;zNs\e(B (1 \e$BJ8;z\e(B)")
-(defvar its-fence-face nil "*\e$B%U%'%s%9I=<($KMQ$$$k\e(B face \e$B$^$?$O\e(B nil")
+(defvar its-fence-open "|" "*\e$B%U%'%s%9$N;OE@$r<($9J8;zNs\e(B (1 \e$BJ8;z0J>e\e(B)")
+(defvar its-fence-close "|" "*\e$B%U%'%s%9$N=*E@$r<($9J8;zNs\e(B (1 \e$BJ8;z0J>e\e(B)")
+(defvar its-fence-face nil "*\e$B%U%'%s%9I=<($KMQ$$$k\e(B face \e$B$^$?$O\e(B nil")
(defconst its-setup-fence-before-insert-SYL nil)
+(defun its-get-fence-face ()
+ (let ((face (and (consp its-fence-face)
+ (or (assoc its-current-language its-fence-face)
+ (assoc t its-fence-face)))))
+ (if face (cdr face) its-fence-face)))
+
(defun its-put-cursor (cursor)
(let ((p (point))
(map (copy-keymap its-mode-map)))
(its-define-select-keys map)
(insert "!")
(add-text-properties p (point) (list 'local-map map
+ 'read-only t
'invisible t
'intangible 'its-part-2
'its-cursor cursor))
;;
(defun its-setup-fence-mode ()
(let ((open-props '(its-start t intangible its-part-1))
- (close-props '(its-end t intangible its-part-2))
+ (close-props '(rear-nonsticky t its-end t intangible its-part-2))
(p (point)) p1)
+ ;; Put open-fence before inhibit-read-only to detect read-nly
(insert its-fence-open)
- (setq p1 (point))
- (add-text-properties p p1 open-props)
- (insert its-fence-close)
- (add-text-properties p1 (point) close-props)
- (if its-fence-face
- (put-text-property 'invisible t p (point)))
- (goto-char p1)
- (its-put-cursor t)))
+ (let ((inhibit-read-only t))
+ (setq p1 (point))
+ (add-text-properties p p1 open-props)
+ (insert its-fence-close)
+ (add-text-properties p1 (point) close-props)
+ (if its-fence-face
+ (put-text-property p (point) 'invisible t))
+ (put-text-property p (point) 'read-only t)
+ (goto-char p1)
+ (its-put-cursor t))))
(defun its-start (key)
(let ((its-setup-fence-before-insert-SYL t))
- (its-input nil key)
- (force-mode-line-update)))
+ (its-input nil key)))
-(defun its-restart (str)
+(defun its-restart (str &optional set-prop)
(let (p)
(its-setup-fence-mode)
(setq p (point))
(insert str)
+ (if set-prop
+ (its-setup-yanked-portion p (point)))
(its-beginning-of-input-buffer)))
(defun its-self-insert-char ()
(interactive)
- (let ((key last-command-char)
+ (let ((inhibit-read-only t)
+ (key last-command-char)
(cursor (get-text-property (point) 'its-cursor))
(syl (get-text-property (1- (point)) 'its-syl)))
(cond
(setq syl nil)))
(its-input syl key)))
-(defvar its-current-map nil)
-(make-variable-buffer-local 'its-current-map)
-(put 'its-current-map 'permanent-local t)
-
(defun its-initial-ISYL ()
(its-get-start-state its-current-map))
;;; ITS State Machine
;;;
+(defvar its-disable-special-action nil)
+
;; Return CURSOR
(defun its-state-machine (state key emit)
(let ((next-state (its-get-next-state state key))
expr-output-back kst/t output keyseq back)
(cond
;; proceed to next status
- (next-state
+ ((and next-state
+ (not (and its-disable-special-action
+ (eq (its-get-kst/t next-state) t))))
(setq kst/t (its-get-kst/t next-state)
output (its-get-output next-state)
keyseq (its-get-keyseq next-state))
(cond
+ ;; Special actions.
+ ((eq kst/t t)
+ (funcall emit (cons "" keyseq) state 'its-cursor)
+ (apply (car output) (cdr output)))
+
;; Still, it's a intermediate state.
((its-kst-p kst/t)
(funcall emit next-state state nil))
(funcall emit next-state state 'its-cursor)
(its-state-machine-keyseq (substring keyseq kst/t) emit (< key 0)))
- ;; Here we arrive to a terminal state.
- ;; Emit a DSYL, and go ahead.
+ ;; Here we arrive to a terminal state.
+ ;; Emit a DSYL, and go ahead.
(t
(funcall emit next-state state 'its-cursor))))
(progn
(setq its-setup-fence-before-insert-SYL nil)
(its-setup-fence-mode)))
- (its-buffer-delete-SYL oldsyl)
- (its-update-latest-SYL newsyl)
- (let ((p (point)))
- (insert (its-get-output newsyl))
- (add-text-properties p (point)
- (list 'its-syl newsyl
- 'its-map its-current-map
- 'its-lang its-current-language
- 'intangible 'its-part-1))
- (if its-fence-face
- (put-text-property p (point) 'face its-fence-face))
- (its-set-cursor-status cursor)))
+ (let ((inhibit-read-only t))
+ (its-buffer-delete-SYL oldsyl)
+ (its-update-latest-SYL newsyl)
+ (let ((p (point)))
+ (insert (its-get-output newsyl))
+ (add-text-properties p (point)
+ (list 'its-map its-current-map
+ 'its-syl newsyl
+ 'egg-lang its-current-language
+ 'read-only t
+ 'intangible 'its-part-1))
+ (if its-fence-face
+ (put-text-property p (point) 'face (its-get-fence-face)))
+ (its-set-cursor-status cursor))))
(defun its-buffer-delete-SYL (syl)
(let ((len (length (its-get-output syl))))
(defun its-get-next-state (state key)
(let ((kst/t (its-get-kst/t state)))
- (cdr (assq key (car kst/t)))))
+ (and (listp kst/t)
+ (cdr (assq key (car kst/t))))))
;; XXX XXX XXX
(defun its-otherwise-match (expr key)
(emit (lambda (nsyl osyl cursor)
(its-update-latest-SYL nsyl)
cursor))
+ (its-current-map its-current-map)
+ (its-current-select-func its-current-select-func)
+ (its-current-language its-current-language)
+ (its-zhuyin its-zhuyin)
+ (its-previous-select-func its-previous-select-func)
cursor)
(if (null syl)
(setq syl (its-initial-ISYL)))
(t
its-latest-SYL))
(setq i (1+ i)))
- (if eol
+ (if (and syl eol)
(setq cursor (its-state-machine syl -1 emit)))
(not (eq cursor 'its-keyseq-test-failed))))
\f
(defun its-make-next-state (state key keyseq output &optional back)
(let ((next-state (its-new-state output keyseq back))
(kst (its-get-kst/t state)))
- (if kst
- (setcar kst (cons (cons key next-state) (car kst)))
+ (cond
+ ((null kst)
(its-set-kst state (list (list (cons key next-state)))))
+ ((consp kst)
+ (setcar kst (cons (cons key next-state) (car kst))))
+ (t
+ (error "Can't make new state after %S" (its-get-keyseq state))))
next-state))
+
+(defmacro its-defrule-select-mode-temporally (input select-func)
+ `(its-defrule ,input '(its-select-mode-temporally
+ ,(intern (concat "its-select-"
+ (symbol-name select-func))))
+ t))
\f
;;;
(defun its-beginning-of-input-buffer ()
(interactive)
- (its-input-end)
- (if (not (get-text-property (1- (point)) 'its-start))
- (let ((begpos (previous-single-property-change (point) 'its-start)))
- ;; Make SYLs have property of "part 2"
- (put-text-property begpos (point) 'intangible 'its-part-2)
- (goto-char begpos)))
- (its-put-cursor t))
+ (let ((inhibit-read-only t))
+ (its-input-end)
+ (if (not (get-text-property (1- (point)) 'its-start))
+ (let ((begpos (previous-single-property-change (point) 'its-start)))
+ ;; Make SYLs have property of "part 2"
+ (put-text-property begpos (point) 'intangible 'its-part-2)
+ (goto-char begpos)))
+ (its-put-cursor t)))
(defun its-end-of-input-buffer ()
(interactive)
- (its-input-end)
- (if (not (get-text-property (point) 'its-end))
- (let ((endpos (next-single-property-change (point) 'its-end)))
- ;; Make SYLs have property of "part 1"
- (put-text-property (point) endpos 'intangible 'its-part-1)
- (goto-char endpos)))
- (its-put-cursor t))
+ (let ((inhibit-read-only t))
+ (its-input-end)
+ (if (not (get-text-property (point) 'its-end))
+ (let ((endpos (next-single-property-change (point) 'its-end)))
+ ;; Make SYLs have property of "part 1"
+ (put-text-property (point) endpos 'intangible 'its-part-1)
+ (goto-char endpos)))
+ (its-put-cursor t)))
+
+(defun its-kill-line (n)
+ (interactive "p")
+ (let ((inhibit-read-only t)
+ (p (point)))
+ (its-input-end)
+ (if (> n 0)
+ (cond
+ ((get-text-property (1- (point)) 'its-start)
+ (its-cancel-input))
+ ((get-text-property (point) 'its-end)
+ (its-put-cursor t))
+ (t
+ (delete-region (next-single-property-change (point) 'its-end)
+ (point))
+ (its-put-cursor t)))
+ (cond
+ ((get-text-property (point) 'its-end)
+ (its-cancel-input))
+ ((get-text-property (1- (point)) 'its-start)
+ (its-put-cursor t))
+ (t
+ (delete-region (point)
+ (previous-single-property-change (point) 'its-start))
+ (its-put-cursor t))))))
+
+(defun its-cancel-input ()
+ (interactive)
+ (let ((inhibit-read-only t))
+ (delete-region (if (get-text-property (1- (point)) 'its-start)
+ (point)
+ (previous-single-property-change (1- (point)) 'its-start))
+ (if (get-text-property (point) 'its-end)
+ (point)
+ (next-single-property-change (point) 'its-end)))
+ (its-put-cursor t)
+ (its-exit-mode-internal)))
;; TODO: move in VSYL
(defun its-backward-SYL (n)
(interactive "p")
- (its-input-end)
- (let ((syl (get-text-property (1- (point)) 'its-syl))
- (p (point))
- (old-point (point)))
+ (let ((inhibit-read-only t)
+ syl p old-point)
+ (its-input-end)
+ (setq syl (get-text-property (1- (point)) 'its-syl)
+ p (point)
+ old-point (point))
(while (and syl (> n 0))
(setq p (- p (length (its-get-output syl))))
(setq syl (get-text-property (1- p) 'its-syl))
;; TODO: move in VSYL
(defun its-forward-SYL (n)
(interactive "p")
- (its-input-end)
- (let ((syl (get-text-property (point) 'its-syl))
- (p (point))
- (old-point (point)))
+ (let ((inhibit-read-only t)
+ syl p old-point)
+ (its-input-end)
+ (setq syl (get-text-property (point) 'its-syl)
+ p (point)
+ old-point (point))
(while (and syl (> n 0))
(setq p (+ p (length (its-get-output syl))))
(setq syl (get-text-property p 'its-syl))
;; TODO: handle VSYL. KILLFLAG
(defun its-delete-SYL (n killflag)
(interactive "p\nP")
- (its-input-end)
- (let ((syl (get-text-property (point) 'its-syl))
- (p (point)))
+ (let ((inhibit-read-only t)
+ syl p)
+ (its-input-end)
+ (setq syl (get-text-property (point) 'its-syl)
+ p (point))
(while (and syl (> n 0))
(setq p (+ p (length (its-get-output syl))))
(setq syl (get-text-property p 'its-syl))
(if (> n 0)
(progn
(its-put-cursor t)
- (signal 'args-out-of-range (list p n)))
+ (signal 'end-of-buffer nil))
(delete-region (point) p)
+ (its-put-cursor t)
;; Check if empty
- (let ((s (get-text-property (1- (point)) 'its-start))
- (e (get-text-property (point) 'its-end)))
- (if (and s e)
- (its-exit-mode-internal)
- (its-put-cursor t))))))
+ (if (and (get-text-property (1- (point)) 'its-start)
+ (get-text-property (1+ (point)) 'its-end))
+ (its-exit-mode-internal)))))
;; TODO: killflag
(defun its-delete-backward-SYL (n killflag)
(interactive "p\nP")
- (let ((syl (get-text-property (1- (point)) 'its-syl))
+ (let ((inhibit-read-only t)
+ (syl (get-text-property (1- (point)) 'its-syl))
(cursor (get-text-property (point) 'its-cursor)))
(if (null syl)
(signal 'beginning-of-buffer nil)
(setq syl (get-text-property (1- p) 'its-syl))
(setq n (1- n)))
(if (> n 0)
- (signal 'args-out-of-range (list p n))
+ (signal 'beginning-of-buffer nil)
(delete-region p (1+ (point))) ; also delete cursor
+ (its-put-cursor t)
;; Check if empty
- (let ((s (get-text-property (1- (point)) 'its-start))
- (e (get-text-property (point) 'its-end)))
- (if (and s e)
- (its-exit-mode-internal)
- (its-put-cursor t))))))
+ (if (and (get-text-property (1- (point)) 'its-start)
+ (get-text-property (1+ (point)) 'its-end))
+ (its-exit-mode-internal)))))
(defvar its-delete-by-keystroke nil)
(defun its-delete-backward-SYL-by-keystroke (n killflag)
(interactive "p\nP")
- (let ((its-delete-by-keystroke t))
+ (let ((inhibit-read-only t)
+ (its-delete-by-keystroke t))
(its-delete-backward-SYL n killflag)))
;; TODO: killflag
(len (length keyseq))
(p (- (point) (length (its-get-output syl))))
(its-current-map (get-text-property (1- (point)) 'its-map))
+ (its-current-language (get-text-property (1- (point)) 'egg-lang))
back pp)
(if (< n 0)
(signal 'args-out-of-range (list (- (point) n) (point))))
;; Check if empty
((and (get-text-property (1- (point)) 'its-start)
(get-text-property (1+ (point)) 'its-end))
- ;; Delete CURSOR
- (delete-region (point) (1+ (point)))
(its-exit-mode-internal))
((and its-delete-by-keystroke
(null (its-concrete-DSYL-p (get-text-property (1- p) 'its-syl))))
(defun its-transpose-chars (n)
(interactive "p")
- (let ((syl (get-text-property (1- (point)) 'its-syl))
+ (let ((inhibit-read-only t)
+ (syl (get-text-property (1- (point)) 'its-syl))
(cursor (get-text-property (point) 'its-cursor))
keyseq len)
(cond
(delete-region (- (point) (length (its-get-output syl))) (point))
(its-state-machine-keyseq keyseq 'its-buffer-ins/del-SYL)))))))
+(defun its-yank (&optional arg)
+ (interactive "*P")
+ (let ((inhibit-read-only t))
+ (its-input-end)
+ (its-put-cursor t)
+ (yank arg)
+ (its-setup-yanked-portion (region-beginning) (region-end))))
+
+(defun its-yank-pop (arg)
+ (interactive "*p")
+ (let ((inhibit-read-only t))
+ (its-input-end)
+ (its-put-cursor t)
+ (yank-pop arg)
+ (its-setup-yanked-portion (region-beginning) (region-end))))
+
+(defun its-setup-yanked-portion (start end)
+ (let ((yank-before (eq (point) end))
+ (max-sisheng (make-char 'chinese-sisheng 127))
+ p syl lang)
+ (remove-text-properties start end '(intangible nil))
+ (egg-separate-languages start end t)
+ (goto-char start)
+ (while (< (point) end)
+ (setq p (point)
+ lang (get-text-property p 'egg-lang))
+ (if (and
+ (or (equal lang "Chinese-GB") (equal lang "Chinese-CNS"))
+ (<= (following-char) max-sisheng)
+ (setq len (egg-chinese-syllable (buffer-substring (point) end))))
+ (goto-char (+ (point) len))
+ (forward-char))
+ (setq syl (buffer-substring-no-properties p (point)))
+ (put-text-property p (point) 'its-syl (cons syl syl))
+ (if its-fence-face
+ (let ((its-current-language (get-text-property p 'egg-lang)))
+ (put-text-property p (point) 'face (its-get-fence-face)))))
+ (if yank-before
+ (add-text-properties start end '(read-only t intangible its-part-1))
+ (add-text-properties start end '(read-only t intangible its-part-2))
+ (delete-region (point) (1+ (point)))
+ (goto-char start)
+ (its-put-cursor t))))
+
;; Return VOID
(defun its-input-end ()
(let ((cursor (get-text-property (point) 'its-cursor)))
(defun its-exit-mode ()
"Exit ITS mode."
(interactive)
- (its-input-end)
- (its-exit-mode-internal))
-
-(defun its-exit-mode-off-input-method ()
- "Exit ITS mode."
- (interactive)
- (its-input-end)
- (its-exit-mode-internal)
- (inactivate-input-method))
+ (let ((inhibit-read-only t))
+ (its-input-end)
+ (its-put-cursor t)
+ (its-exit-mode-internal)))
;; TODO: handle overwrite-mode, insertion-hook, fill...
(defun its-exit-mode-internal (&optional proceed-to-conversion)
- (let (start end)
+ (let (start end s e)
+ (its-select-previous-mode t)
+ ;; Delete CURSOR
+ (delete-region (point) (1+ (point)))
;; Delete open fence
- (if (get-text-property (1- (point)) 'its-start)
- (setq start (1- (point)))
- (setq start (1- (previous-single-property-change (point) 'its-start))))
- (delete-region start (1+ start))
+ (setq s (if (get-text-property (1- (point)) 'its-start)
+ (point)
+ (previous-single-property-change (point) 'its-start))
+ start (- s (length its-fence-open)))
+ (delete-region start s)
;; Delete close fence
- (if (get-text-property (point) 'its-end)
- (setq end (point))
- (setq end (next-single-property-change (point) 'its-end)))
- (delete-region end (1+ end))
- ;; Remove all properties added by ITS
- (remove-text-properties start end '(its-map nil
- face nil
- intangible nil))
+ (setq end (if (get-text-property (point) 'its-end)
+ (point)
+ (next-single-property-change (point) 'its-end))
+ e (+ end (length its-fence-close)))
+ (delete-region end e)
(if proceed-to-conversion
(egg-convert-region start end)
- (remove-text-properties start end '(its-lang nil its-syl nil))
+ ;; Remove all properties
+ (set-text-properties start end nil)
(egg-do-auto-fill)
(run-hooks 'input-method-after-insert-chunk-hook))))
(defun its-kick-convert-region ()
(interactive)
- (its-input-end)
- (its-exit-mode-internal t))
+ (let ((inhibit-read-only t))
+ (its-input-end)
+ (its-put-cursor t)
+ (its-exit-mode-internal t)))
+
+(defun its-kick-convert-region-or-self-insert ()
+ (interactive)
+ (let ((syl (and (null (get-text-property (point) 'its-cursor))
+ (get-text-property (1- (point)) 'its-syl))))
+ (if (its-keyseq-acceptable-p (vector last-command-char) syl)
+ (its-self-insert-char)
+ (its-kick-convert-region))))
(defun its-in-fence-p ()
(eq (get-text-property (point) 'intangible) 'its-part-2))
(oldlen (length its-translation-result)))
(setq its-translation-result (concat its-translation-result output))
(put-text-property oldlen (length its-translation-result)
- 'its-lang its-current-language
+ 'egg-lang its-current-language
its-translation-result)))
cursor)
(defun its-translate-region (start end)
+ (interactive "r")
(its-translate-region-internal start end)
- (remove-text-properties start (point) '(its-lang nil)))
+ (set-text-properties start (point) nil))
(defun its-translate-region-internal (start end)
- (interactive "r")
(setq its-translation-result "")
(goto-char start)
(let ((i 0)
(delete-region start end)
(insert its-translation-result)))
\f
+(defun its-set-mode-line-title ()
+ (let ((title (its-get-indicator its-current-map)))
+ (setq current-input-method-title (if its-previous-select-func
+ (concat "<" title ">")
+ title))
+ (force-mode-line-update)))
+
+(defun its-select-mode-temporally (func)
+ (let ((select-func its-current-select-func))
+ (funcall func)
+ (if (null its-previous-select-func)
+ (setq its-previous-select-func select-func))
+ (its-set-mode-line-title)))
+
+(defun its-select-previous-mode (&optional quiet)
+ (interactive)
+ (if (null its-previous-select-func)
+ (if (null quiet)
+ (beep))
+ (funcall its-previous-select-func)
+ (setq its-previous-select-func nil)
+ (its-set-mode-line-title)))
+
(provide 'its)
;;; its.el ends here.
projects / elisp / egg.git / blobdiff