(require 'ja-dic-utl)
(defvar kkc-input-method-title "漢"
"String denoting KKC input method.
This string is shown at mode line when users are in KKC mode.")
(defvar kkc-init-file-name "~/.kkcrc"
"Name of a file which contains user's initial setup code for KKC.")
(defvar kkc-init-file-flag nil)
(defvar kkc-lookup-cache nil)
(defconst kkc-lookup-cache-tag 'kkc-lookup-cache-2)
(defun kkc-save-init-file ()
"Save initial setup code for KKC to a file specified by `kkc-init-file-name'"
(if (and kkc-init-file-flag
(not (eq kkc-init-file-flag t)))
(let ((coding-system-for-write 'iso-2022-7bit)
(print-length nil))
(write-region (format "(setq kkc-lookup-cache '%S)\n" kkc-lookup-cache)
nil
kkc-init-file-name))))
(defvar kkc-show-conversion-list-index-chars
"1234567890")
(defun kkc-help ()
"Show key bindings available while converting by KKC."
(interactive)
(with-output-to-temp-buffer "*Help*"
(princ (substitute-command-keys "\\{kkc-keymap}"))))
(defvar kkc-keymap
(let ((map (make-sparse-keymap))
(len (length kkc-show-conversion-list-index-chars))
(i 0))
(while (< i len)
(define-key map
(char-to-string (aref kkc-show-conversion-list-index-chars i))
'kkc-select-from-list)
(setq i (1+ i)))
(define-key map " " 'kkc-next)
(define-key map "\r" 'kkc-terminate)
(define-key map "\C-@" 'kkc-first-char-only)
(define-key map "\C-n" 'kkc-next)
(define-key map "\C-p" 'kkc-prev)
(define-key map "\C-i" 'kkc-shorter)
(define-key map "\C-o" 'kkc-longer)
(define-key map "I" 'kkc-shorter-conversion)
(define-key map "O" 'kkc-longer-phrase)
(define-key map "\C-c" 'kkc-cancel)
(define-key map "\C-?" 'kkc-cancel)
(define-key map "\C-f" 'kkc-next-phrase)
(define-key map "K" 'kkc-katakana)
(define-key map "H" 'kkc-hiragana)
(define-key map "l" 'kkc-show-conversion-list-or-next-group)
(define-key map "L" 'kkc-show-conversion-list-or-prev-group)
(define-key map [?\C- ] 'kkc-first-char-only)
(define-key map [delete] 'kkc-cancel)
(define-key map [return] 'kkc-terminate)
(define-key map "\C-h" 'kkc-help)
map)
"Keymap for KKC (Kana Kanji Converter).")
(defvar kkc-original-kana nil)
(defvar kkc-current-key nil)
(defvar kkc-current-conversions nil)
(defvar kkc-current-conversions-width nil)
(defcustom kkc-show-conversion-list-count 4
"*Count of successive `kkc-next' or `kkc-prev' to show conversion list.
When you type SPC or C-p successively this count while using the input
method `japanese', the conversion candidates are shown in the echo
area while indicating the current selection by `<N>'."
:group 'mule
:type 'integer)
(defvar kkc-next-count nil)
(defvar kkc-prev-count nil)
(defvar kkc-overlay-head nil)
(defvar kkc-overlay-tail nil)
(defvar kkc-length-head nil)
(defvar kkc-length-converted nil)
(defvar kkc-cursor-type nil)
(defun kkc-lookup-key (len &optional postfix prefer-noun)
(unless kkc-init-file-flag
(setq kkc-init-file-flag t
kkc-lookup-cache nil)
(add-hook 'kill-emacs-hook 'kkc-save-init-file)
(if (file-readable-p kkc-init-file-name)
(condition-case nil
(load-file kkc-init-file-name)
(kkc-error "Invalid data in %s" kkc-init-file-name))))
(or (and (nested-alist-p kkc-lookup-cache)
(eq (car kkc-lookup-cache) kkc-lookup-cache-tag))
(setq kkc-lookup-cache (list kkc-lookup-cache-tag)
kkc-init-file-flag 'kkc-lookup-cache))
(let ((entry (lookup-nested-alist kkc-current-key kkc-lookup-cache len 0 t)))
(if (consp (car entry))
(setq kkc-length-converted len
kkc-current-conversions-width nil
kkc-current-conversions (car entry))
(setq entry (skkdic-lookup-key kkc-current-key len postfix prefer-noun))
(if entry
(progn
(setq kkc-length-converted len
kkc-current-conversions-width nil
kkc-current-conversions (cons 1 entry))
(if postfix
(progn
(set-nested-alist kkc-current-key kkc-current-conversions
kkc-lookup-cache kkc-length-converted)
(setq kkc-init-file-flag 'kkc-lookup-cache)))
t)
(if (= len 1)
(setq kkc-length-converted 1
kkc-current-conversions-width nil
kkc-current-conversions (cons 0 nil)))))))
(put 'kkc-error 'error-conditions '(kkc-error error))
(defun kkc-error (&rest args)
(signal 'kkc-error (apply 'format args)))
(defvar kkc-converting nil)
(defvar kkc-after-update-conversion-functions nil
"Functions to run after a conversion is selected in `japanese' input method.
With this input method, a user can select a proper conversion from
candidate list. Each time he changes the selection, functions in this
list are called with two arguments; starting and ending buffer
positions that contains the current selection.")
(defun kkc-region (from to)
"Convert Kana string in the current region to Kanji-Kana mixed string.
Users can select a desirable conversion interactively.
When called from a program, expects two arguments,
positions FROM and TO (integers or markers) specifying the target region.
When it returns, the point is at the tail of the selected conversion,
and the return value is the length of the conversion."
(interactive "r")
(setq kkc-original-kana (buffer-substring from to))
(goto-char from)
(if (overlayp kkc-overlay-head)
(move-overlay kkc-overlay-head from to)
(setq kkc-overlay-head (make-overlay from to nil nil t))
(overlay-put kkc-overlay-head 'face 'highlight))
(if (overlayp kkc-overlay-tail)
(move-overlay kkc-overlay-tail to to)
(setq kkc-overlay-tail (make-overlay to to nil nil t))
(overlay-put kkc-overlay-tail 'face 'underline))
(setq kkc-current-key (string-to-vector kkc-original-kana))
(setq kkc-length-head (length kkc-current-key))
(setq kkc-length-converted 0)
(unwind-protect
(let ((current-input-method-title kkc-input-method-title)
(input-method-function nil)
(modified-p (buffer-modified-p))
(first t))
(while (not (kkc-lookup-key kkc-length-head nil first))
(setq kkc-length-head (1- kkc-length-head)
first nil))
(goto-char to)
(kkc-update-conversion 'all)
(setq kkc-next-count 1 kkc-prev-count 0)
(if (and (>= kkc-next-count kkc-show-conversion-list-count)
(>= (length kkc-current-conversions) 3))
(kkc-show-conversion-list-or-next-group))
(force-mode-line-update)
(setq kkc-converting t)
(message nil)
(while kkc-converting
(set-buffer-modified-p modified-p)
(let* ((overriding-terminal-local-map kkc-keymap)
(help-char nil)
(keyseq (read-key-sequence nil))
(cmd (lookup-key kkc-keymap keyseq)))
(if (commandp cmd)
(condition-case err
(progn
(cond ((eq cmd 'kkc-next)
(setq kkc-next-count (1+ kkc-next-count)
kkc-prev-count 0))
((eq cmd 'kkc-prev)
(setq kkc-prev-count (1+ kkc-prev-count)
kkc-next-count 0))
(t
(setq kkc-next-count 0 kkc-prev-count 0)))
(call-interactively cmd))
(kkc-error (message "%s" (cdr err)) (beep)))
(setq unread-input-method-events
(append (string-to-list (this-single-command-raw-keys))
unread-input-method-events))
(kkc-terminate))))
(force-mode-line-update)
(goto-char (overlay-end kkc-overlay-tail))
(- (overlay-start kkc-overlay-head) from))
(delete-overlay kkc-overlay-head)
(delete-overlay kkc-overlay-tail)))
(defun kkc-terminate ()
"Exit from KKC mode by fixing the current conversion."
(interactive)
(goto-char (overlay-end kkc-overlay-tail))
(move-overlay kkc-overlay-head (point) (point))
(setq kkc-converting nil))
(defun kkc-cancel ()
"Exit from KKC mode by canceling any conversions."
(interactive)
(goto-char (overlay-start kkc-overlay-head))
(delete-region (overlay-start kkc-overlay-head)
(overlay-end kkc-overlay-tail))
(insert kkc-original-kana)
(setq kkc-converting nil))
(defun kkc-first-char-only ()
"Select only the first character currently converted."
(interactive)
(goto-char (overlay-start kkc-overlay-head))
(forward-char 1)
(delete-region (point) (overlay-end kkc-overlay-tail))
(kkc-terminate))
(defun kkc-next ()
"Select the next candidate of conversion."
(interactive)
(let ((idx (1+ (car kkc-current-conversions))))
(if (< idx 0)
(setq idx 1))
(if (>= idx (length kkc-current-conversions))
(setq idx 0))
(setcar kkc-current-conversions idx)
(if (> idx 1)
(progn
(set-nested-alist kkc-current-key kkc-current-conversions
kkc-lookup-cache kkc-length-converted)
(setq kkc-init-file-flag 'kkc-lookup-cache)))
(if (or kkc-current-conversions-width
(>= kkc-next-count kkc-show-conversion-list-count))
(kkc-show-conversion-list-update))
(kkc-update-conversion)))
(defun kkc-prev ()
"Select the previous candidate of conversion."
(interactive)
(let ((idx (1- (car kkc-current-conversions))))
(if (< idx 0)
(setq idx (1- (length kkc-current-conversions))))
(setcar kkc-current-conversions idx)
(if (> idx 1)
(progn
(set-nested-alist kkc-current-key kkc-current-conversions
kkc-lookup-cache kkc-length-converted)
(setq kkc-init-file-flag 'kkc-lookup-cache)))
(if (or kkc-current-conversions-width
(>= kkc-prev-count kkc-show-conversion-list-count))
(kkc-show-conversion-list-update))
(kkc-update-conversion)))
(defun kkc-select-from-list ()
"Select one candidate from the list currently shown in echo area."
(interactive)
(let (idx)
(if kkc-current-conversions-width
(let ((len (length kkc-show-conversion-list-index-chars))
(maxlen (- (aref (aref kkc-current-conversions-width 0) 1)
(aref (aref kkc-current-conversions-width 0) 0)))
(i 0))
(if (> len maxlen)
(setq len maxlen))
(while (< i len)
(if (= (aref kkc-show-conversion-list-index-chars i)
last-input-event)
(setq idx i i len)
(setq i (1+ i))))))
(if idx
(progn
(setcar kkc-current-conversions
(+ (aref (aref kkc-current-conversions-width 0) 0) idx))
(kkc-show-conversion-list-update)
(kkc-update-conversion))
(setq unread-input-method-events
(cons last-input-event unread-input-method-events))
(kkc-terminate))))
(defun kkc-katakana ()
"Convert to Katakana."
(interactive)
(setcar kkc-current-conversions -1)
(kkc-update-conversion 'all))
(defun kkc-hiragana ()
"Convert to hiragana."
(interactive)
(setcar kkc-current-conversions 0)
(kkc-update-conversion))
(defun kkc-shorter ()
"Make the Kana string to be converted shorter."
(interactive)
(if (<= kkc-length-head 1)
(kkc-error "Can't be shorter"))
(setq kkc-length-head (1- kkc-length-head))
(if (> kkc-length-converted kkc-length-head)
(let ((len kkc-length-head))
(setq kkc-length-converted 0)
(while (not (kkc-lookup-key len))
(setq len (1- len)))))
(kkc-update-conversion 'all))
(defun kkc-longer ()
"Make the Kana string to be converted longer."
(interactive)
(if (>= kkc-length-head (length kkc-current-key))
(kkc-error "Can't be longer"))
(setq kkc-length-head (1+ kkc-length-head))
(kkc-lookup-key kkc-length-head 'postfix)
(kkc-update-conversion 'all))
(defun kkc-shorter-conversion ()
"Make the Kana string to be converted shorter."
(interactive)
(if (<= kkc-length-converted 1)
(kkc-error "Can't be shorter"))
(let ((len (1- kkc-length-converted)))
(setq kkc-length-converted 0)
(while (not (kkc-lookup-key len))
(setq len (1- len))))
(kkc-update-conversion 'all))
(defun kkc-longer-phrase ()
"Make the current phrase (BUNSETSU) longer without looking up dictionary."
(interactive)
(if (>= kkc-length-head (length kkc-current-key))
(kkc-error "Can't be longer"))
(setq kkc-length-head (1+ kkc-length-head))
(kkc-update-conversion 'all))
(defun kkc-next-phrase ()
"Fix the currently converted string and try to convert the remaining string."
(interactive)
(if (>= kkc-length-head (length kkc-current-key))
(kkc-terminate)
(setq kkc-length-head (- (length kkc-current-key) kkc-length-head))
(goto-char (overlay-end kkc-overlay-head))
(while (and (< (point) (overlay-end kkc-overlay-tail))
(looking-at "\\CH"))
(goto-char (match-end 0))
(setq kkc-length-head (1- kkc-length-head)))
(if (= kkc-length-head 0)
(kkc-terminate)
(let ((newkey (make-vector kkc-length-head 0))
(idx (- (length kkc-current-key) kkc-length-head))
(len kkc-length-head)
(i 0))
(setq kkc-original-kana "")
(while (< i kkc-length-head)
(aset newkey i (aref kkc-current-key (+ idx i)))
(setq kkc-original-kana
(concat kkc-original-kana (char-to-string (aref newkey i))))
(setq i (1+ i)))
(setq kkc-current-key newkey)
(setq kkc-length-converted 0)
(while (and (not (kkc-lookup-key kkc-length-head nil
(< kkc-length-head len)))
(> kkc-length-head 1))
(setq kkc-length-head (1- kkc-length-head)))
(let ((pos (point))
(tail (overlay-end kkc-overlay-tail)))
(move-overlay kkc-overlay-head pos tail)
(move-overlay kkc-overlay-tail tail tail))
(kkc-update-conversion 'all)))))
(defun kkc-setup-current-conversions-width ()
(let ((convs (cdr kkc-current-conversions))
(len (length kkc-current-conversions))
(idx 1))
(setq kkc-current-conversions-width (make-vector len nil))
(aset kkc-current-conversions-width 0 (vector len -2 nil))
(while convs
(aset kkc-current-conversions-width idx
(+ (string-width (car convs)) 4))
(setq convs (cdr convs)
idx (1+ idx)))))
(defun kkc-show-conversion-list-or-next-group ()
"Show list of available conversions in echo area with index numbers.
If the list is already shown, show the next group of conversions,
and change the current conversion to the first one in the group."
(interactive)
(if (< (length kkc-current-conversions) 3)
(kkc-error "No alternative"))
(if kkc-current-conversions-width
(let ((next-idx (aref (aref kkc-current-conversions-width 0) 1)))
(if (< next-idx (length kkc-current-conversions-width))
(setcar kkc-current-conversions next-idx)
(setcar kkc-current-conversions 1))
(kkc-show-conversion-list-update)
(kkc-update-conversion))
(kkc-setup-current-conversions-width)
(kkc-show-conversion-list-update)))
(defun kkc-show-conversion-list-or-prev-group ()
"Show list of available conversions in echo area with index numbers.
If the list is already shown, show the previous group of conversions,
and change the current conversion to the last one in the group."
(interactive)
(if (< (length kkc-current-conversions) 3)
(kkc-error "No alternative"))
(if kkc-current-conversions-width
(let ((this-idx (aref (aref kkc-current-conversions-width 0) 0)))
(if (> this-idx 1)
(setcar kkc-current-conversions (1- this-idx))
(setcar kkc-current-conversions
(1- (length kkc-current-conversions-width))))
(kkc-show-conversion-list-update)
(kkc-update-conversion))
(kkc-setup-current-conversions-width)
(kkc-show-conversion-list-update)))
(defun kkc-show-conversion-list-update ()
(or kkc-current-conversions-width
(kkc-setup-current-conversions-width))
(let* ((current-idx (car kkc-current-conversions))
(first-slot (aref kkc-current-conversions-width 0))
(this-idx (aref first-slot 0))
(next-idx (aref first-slot 1))
(msg (aref first-slot 2)))
(if (< current-idx this-idx)
(setq this-idx 1 msg nil)
(if (>= current-idx next-idx)
(setq this-idx next-idx msg nil)))
(if (not msg)
(let ((len (length kkc-current-conversions))
(max-width (window-width (minibuffer-window)))
(width-table kkc-current-conversions-width)
(width 0)
(idx this-idx)
(max-items (length kkc-show-conversion-list-index-chars))
l)
(while (<= idx current-idx)
(if (and (<= (+ width (aref width-table idx)) max-width)
(< (- idx this-idx) max-items))
(setq width (+ width (aref width-table idx)))
(setq this-idx idx width (aref width-table idx)))
(setq idx (1+ idx)
l (cdr l)))
(aset first-slot 0 this-idx)
(while (and (< idx len)
(<= (+ width (aref width-table idx)) max-width)
(< (- idx this-idx) max-items))
(setq width (+ width (aref width-table idx))
idx (1+ idx)
l (cdr l)))
(aset first-slot 1 (setq next-idx idx))
(setq l (nthcdr this-idx kkc-current-conversions))
(setq msg (format " %c %s"
(aref kkc-show-conversion-list-index-chars 0)
(propertize (car l)
'kkc-conversion-index this-idx))
idx (1+ this-idx)
l (cdr l))
(while (< idx next-idx)
(setq msg (format "%s %c %s"
msg
(aref kkc-show-conversion-list-index-chars
(- idx this-idx))
(propertize (car l)
'kkc-conversion-index idx))
idx (1+ idx)
l (cdr l)))
(aset first-slot 2 msg)))
(if (> current-idx 0)
(let ((pos 3)
(limit (length msg)))
(remove-text-properties 0 (length msg) '(face nil) msg)
(while (not (eq (get-text-property pos 'kkc-conversion-index msg)
current-idx))
(setq pos (next-single-property-change pos 'kkc-conversion-index
msg limit)))
(put-text-property pos (next-single-property-change
pos 'kkc-conversion-index msg limit)
'face 'highlight msg)))
(let ((message-log-max nil))
(message "%s" msg))))
(defun kkc-update-conversion (&optional all)
(goto-char (overlay-start kkc-overlay-head))
(cond ((= (car kkc-current-conversions) 0) (let ((i 0))
(while (< i kkc-length-converted)
(insert (aref kkc-current-key i))
(setq i (1+ i)))))
((= (car kkc-current-conversions) -1) (let ((i 0))
(while (< i kkc-length-converted)
(insert (japanese-katakana (aref kkc-current-key i)))
(setq i (1+ i)))))
(t
(insert (nth (car kkc-current-conversions) kkc-current-conversions))))
(delete-region (point) (overlay-start kkc-overlay-tail))
(if all
(let ((len (length kkc-current-key))
(i kkc-length-converted))
(delete-region (overlay-start kkc-overlay-tail)
(overlay-end kkc-overlay-head))
(while (< i kkc-length-head)
(if (= (car kkc-current-conversions) -1)
(insert (japanese-katakana (aref kkc-current-key i)))
(insert (aref kkc-current-key i)))
(setq i (1+ i)))
(let ((pos (point)))
(while (< i len)
(insert (aref kkc-current-key i))
(setq i (1+ i)))
(move-overlay kkc-overlay-head
(overlay-start kkc-overlay-head) pos)
(delete-region (point) (overlay-end kkc-overlay-tail)))))
(unwind-protect
(run-hook-with-args 'kkc-after-update-conversion-functions
(overlay-start kkc-overlay-head)
(overlay-end kkc-overlay-head))
(goto-char (overlay-end kkc-overlay-tail))))
(provide 'kkc)