;;;
;;; Copyright (c) 2003-2008 uim Project http://code.google.com/p/uim/
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;;    notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;;    notice, this list of conditions and the following disclaimer in the
;;;    documentation and/or other materials provided with the distribution.
;;; 3. Neither the name of authors nor the names of its contributors
;;;    may be used to endorse or promote products derived from this software
;;;    without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND
;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE
;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
;;; SUCH DAMAGE.
;;;;

;;; tutcode.scm: TUT-Code for Japanese input.
;;;
;;; TUT-Code<http://www.crew.sfc.keio.ac.jp/~chk/>ϥץȡ
;;; TUT-CodeܸϤԤ
;;;
;;; ǥեȤΥɽ(ȥϤʸȤб)
;;; Ǥtutcode-ruleQWERTYܡѡ
;;;
;;; Ѵ
;;;   ַΤ߼Ƥޤ
;;;   ƵŪѴǽǤ
;;;   Υ르ꥺtc-2.1ΤΤǤ
;;; 
;;; ڸ򤼽Ѵ
;;;   ñַ򤼽ѴǤޤ
;;;   򤼽Ѵtc2Ʊ(SKKƱͤη)Ǥ
;;; 
;;; * 򤼽Ѵ(:/usr/local/share/tc/mazegaki.dic)ؤΥ
;;;   libuim-skk.soεǽȤäƤޤ
;;;   ΤᡢؽǽSKKƱͤưˤʤޤ:
;;;     ꤷϼѴƬޤ
;;;     ꤷϸĿͼ(~/.mazegaki.dic)¸ޤ
;;;   γؽǽ򥪥դˤˤϡ
;;;   tutcode-enable-mazegaki-learning?ѿ#fꤷƤ
;;; 
;;; * ѤѴϼưŪˤϹԤޤ
;;;   ɤߤŪ""ղäѴƤ
;;; 
;;; * 򤼽Ѵط̤εǽ
;;;  - ַ򤼽Ѵ
;;;  - 򤼽ѴؤϿ
;;;  - ɤߤ򿭤Ф̤᤿ꤹ뵡ǽɤߤ䴰ǽ
;;;
;;; 
;;; * ɽΰѹϡ㤨~/.uimǰʲΤ褦˵Ҥ롣
;;;   (require "tutcode.scm")
;;;   (tutcode-rule-set-sequences!
;;;     '(((("s" " "))(""))                ; ѹ
;;;       ((("a" "l" "i"))("Ľ"))            ; ɲ
;;;       ((("d" "l" "u"))("" ""))       ; ʤޤ
;;;       ((("d" "l" "d" "u"))("" ""))))
;;;
;;; * T-CodeȤ
;;;   uim-pref-gtkꤹ뤫~/.uimǰʲΤ褦ꤷƤ
;;;    (define tutcode-rule-filename "/usr/local/share/uim/tcode.scm")
;;;    (define tutcode-mazegaki-start-sequence "fj")
;;;    (define tutcode-bushu-start-sequence "jf")
;;;
;;; ڥˤĤơ
;;; generic.scm١ˤưʲѹ򤷤Ƥ롣
;;;  * Υڡͭˤʤ褦ѹ
;;;  * Ҥ餬/ʥ⡼ɤڤؤɲá
;;;  * rk̤(preedit)ʸɽ򤷤ʤ褦ˤ
;;;    (EmacsT/TUT-CodeϴĶtc2ǤɽʤΤǤ˹碌)
;;;  * 򤼽ѴǤSKKμȤΤǡ
;;;    skk.scmΤʴѴɬפʬߡ
;;;  * Ѵǽɲá

(require "generic.scm")
(require-custom "tutcode-custom.scm")
(require-custom "generic-key-custom.scm")
(require-custom "tutcode-key-custom.scm")
(load-plugin "skk") ;SKKθ򤼽񤭼θΤᡢlibuim-skk.so
(require "tutcode-bushudic.scm") ;Ѵ

;;; user configs

;; widgets and actions

;; widgets
(define tutcode-widgets '(widget_tutcode_input_mode))

;; default activity for each widgets
(define default-widget_tutcode_input_mode 'action_tutcode_direct)

;; actions of widget_tutcode_input_mode
(define tutcode-input-mode-actions
  '(action_tutcode_direct
    action_tutcode_hiragana
    action_tutcode_katakana))

;;; Ѥ륳ɽ
;;; tutcode-context-new(tutcode-custom-load-rule!)
(define tutcode-rule ())

;;; ɽѹ/ɲä뤿Υɽ
;;; ~/.uimtutcode-rule-set-sequences!Ͽơ
;;; tutcode-context-newȿǤ롣
(define tutcode-rule-userconfig ())

;;; ѥ٥ʸΥꥹ
(define tutcode-heading-label-char-list
  '("1" "2" "3" "4" "5" "6" "7" "8" "9" "0"
    "a" "b" "c" "d" "e" "f" "g" "h" "i" "j"
    "k" "l" "m" "n" "o" "p" "q" "r" "s" "t"
    "u" "v" "w" "x" "y" "z"
    "A" "B" "C" "D" "E" "F" "G" "H" "I" "J"
    "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T"
    "U" "V" "W" "X" "Y" "Z"))

;;; implementations

;;; 򤼽ѴνäƤ뤫ɤ
(define tutcode-dic-init #f)

(define tutcode-prepare-activation
  (lambda (tc)
    (let ((rkc (tutcode-context-rk-context tc)))
      (rk-flush rkc))))

(register-action 'action_tutcode_direct
		 (lambda (tc)
		   '(ja_halfwidth_alnum
		     "a"
		     "ľ"
		     "ľϥ⡼"))
		 (lambda (tc)
		   (not (tutcode-context-on? tc)))
		 (lambda (tc)
		   (tutcode-prepare-activation tc)
                   (tutcode-flush tc)
                   (tutcode-context-set-state! tc 'tutcode-state-off)
                   (tutcode-update-preedit tc))) ; flushǥꥢɽȿ

(register-action 'action_tutcode_hiragana
		 (lambda (tc)
		   '(ja_hiragana
		     ""
		     "Ҥ餬"
		     "Ҥ餬ʥ⡼"))
		 (lambda (tc)
		   (and (tutcode-context-on? tc)
			(not (tutcode-context-katakana-mode? tc))))
		 (lambda (tc)
		   (tutcode-prepare-activation tc)
                   (if (not (tutcode-context-on? tc)) ; Ѵ֤ѹʤ
                     (tutcode-context-set-state! tc 'tutcode-state-on))
		   (tutcode-context-set-katakana-mode! tc #f)))

(register-action 'action_tutcode_katakana
		 (lambda (tc)
		   '(ja_katakana
		     ""
		     ""
		     "ʥ⡼"))
		 (lambda (tc)
		   (and (tutcode-context-on? tc)
			(tutcode-context-katakana-mode? tc)))
		 (lambda (tc)
		   (tutcode-prepare-activation tc)
                   (if (not (tutcode-context-on? tc)) ; Ѵ֤ѹʤ
                     (tutcode-context-set-state! tc 'tutcode-state-on))
		   (tutcode-context-set-katakana-mode! tc #t)))

;; Update widget definitions based on action configurations. The
;; procedure is needed for on-the-fly reconfiguration involving the
;; custom API
(define tutcode-configure-widgets
  (lambda ()
    (register-widget 'widget_tutcode_input_mode
		     (activity-indicator-new tutcode-input-mode-actions)
		     (actions-new tutcode-input-mode-actions))))

(define tutcode-context-rec-spec
  (append
   context-rec-spec
   '((rk-context    ()) ; ȥʸؤѴΤΥƥ
     ;;; TUT-CodeϾ
     ;;; 'tutcode-state-off TUT-Code
     ;;; 'tutcode-state-on TUT-Code
     ;;; 'tutcode-state-yomi 򤼽Ѵɤ
     ;;; 'tutcode-state-converting 򤼽Ѵθ
     ;;; 'tutcode-state-bushu ϡѴ
     (state 'tutcode-state-off)
     ;;; ʥ⡼ɤɤ
     ;;; #t: ʥ⡼ɡ#f: Ҥ餬ʥ⡼ɡ
     (katakana-mode #f)
     ;;; 򤼽Ѵ/Ѵоݤʸꥹ(ս)
     ;;; (: 򤼽Ѵɤߡ֤פϤ硢("" "" ""))
     (head ())
     ;;; 򤼽Ѵθֹ
     (nth 0)
     ;;; 򤼽Ѵθ
     (nr-candidates 0)
     ;;; 䥦ɥɽ椫ɤ
     (candidate-window #f))))
(define-record 'tutcode-context tutcode-context-rec-spec)
(define tutcode-context-new-internal tutcode-context-new)
(define tutcode-context-katakana-mode? tutcode-context-katakana-mode)
(define (tutcode-context-on? pc)
  (not (eq? (tutcode-context-state pc) 'tutcode-state-off)))

;;; TUT-CodeΥƥȤ򿷤롣
;;; @return ƥ
(define (tutcode-context-new id im)
  (if (not tutcode-dic-init)
    (begin
      (set! tutcode-dic-init #t)
      (skk-lib-dic-open tutcode-dic-filename #f "localhost" 0 'unspecified)
      (tutcode-read-personal-dictionary)))
  (let ((tc (tutcode-context-new-internal id im)))
    (tutcode-context-set-widgets! tc tutcode-widgets)
    (tutcode-custom-load-rule! tutcode-rule-filename)
    (if tutcode-use-dvorak?
      (set! tutcode-rule (tutcode-rule-qwerty-to-dvorak tutcode-rule)))
    ;; tutcode-mazegaki/bushu-start-sequenceϡ
    ;; tutcode-use-dvorak?ΤȤDvorakΥ󥹤ȤߤʤȿǤ롣
    ;; Ĥޤꡢruleqwerty-to-dvorakѴȿǤ롣
    (tutcode-custom-set-mazegaki/bushu-start-sequence!)
    (tutcode-rule-commit-sequences! tutcode-rule-userconfig)
    (tutcode-context-set-rk-context! tc (rk-context-new tutcode-rule #t #f))
    tc))

;;; Ҥ餬/ʥ⡼ɤڤؤԤ
;;; ξ֤Ҥ餬ʥ⡼ɤξϥʥ⡼ɤڤؤ롣
;;; ξ֤ʥ⡼ɤξϤҤ餬ʥ⡼ɤڤؤ롣
;;; @param pc ƥȥꥹ
(define (tutcode-context-kana-toggle pc)
  (let ((s (tutcode-context-katakana-mode? pc)))
    (tutcode-context-set-katakana-mode! pc (not s))))

;;; 򤼽ѴѸĿͼɤ߹ࡣ
(define (tutcode-read-personal-dictionary)
  (if (not (setugid?))
      (skk-lib-read-personal-dictionary tutcode-personal-dic-filename)))

;;; 򤼽ѴѸĿͼ񤭹ࡣ
(define (tutcode-save-personal-dictionary)
  (if (and
        tutcode-enable-mazegaki-learning?
        (not (setugid?)))
      (skk-lib-save-personal-dictionary tutcode-personal-dic-filename)))

;;; ȥʸؤѴΤrk-push-key!ƤӽФ
;;; ͤ#fǤʤС(ꥹ)car֤
;;; ʥ⡼ɤξͥꥹȤcadr֤
;;; (rk-push-key!ϥȥξ#f֤)
;;; @param pc ƥȥꥹ
;;; @param key ʸ
(define (tutcode-push-key! pc key)
  (let ((res (rk-push-key! (tutcode-context-rk-context pc) key)))
    (and res
      (if
        (and
          (not (null? (cdr res)))
          (tutcode-context-katakana-mode? pc))
        (cadr res)
        (car res)))))

;;; Ѵ֤򥯥ꥢ롣
;;; @param pc ƥȥꥹ
(define (tutcode-flush pc)
  (rk-flush (tutcode-context-rk-context pc))
  (if (tutcode-context-on? pc) ; ջ˸ƤФ줿ϥˤ
    (tutcode-context-set-state! pc 'tutcode-state-on)) ; Ѵ֤򥯥ꥢ
  (tutcode-context-set-head! pc ())
  (tutcode-context-set-nr-candidates! pc 0)
  (tutcode-reset-candidate-window pc))

;;; ѴоݤʸꥹȤʸ롣
;;; @param sl ʸꥹ
(define (tutcode-make-string sl)
  (if (null? sl)
    ""
    (string-append (tutcode-make-string (cdr sl)) (car sl))))

;;; 򤼽Ѵnܤθ֤
;;; @param pc ƥȥꥹ
;;; @param n оݤθֹ
(define (tutcode-get-nth-candidate pc n)
  (let* ((head (tutcode-context-head pc))
         (cand (skk-lib-get-nth-candidate
                n (tutcode-make-string head) "" "" #f)))
    cand))

;;; 򤼽Ѵθθ֤
;;; @param pc ƥȥꥹ
(define (tutcode-get-current-candidate pc)
  (tutcode-get-nth-candidate pc (tutcode-context-nth pc)))

;;; 򤼽Ѵdzꤷʸ֤
;;; @param pc ƥȥꥹ
(define (tutcode-prepare-commit-string pc)
  (let* ((res (tutcode-get-current-candidate pc)))
    ;; ĤΥ٥륭θꤹȤǤ褦ˡ
    ;; tutcode-enable-mazegaki-learning?#fξϸ¤ӽѤʤ
    ;; (:֤פѴˤơdǡֲסeǡֲפ)
    (if tutcode-enable-mazegaki-learning?
      (begin
        ;; skk-lib-commit-candidateƤ֤ȳؽԤ졢礬ѹ
        (skk-lib-commit-candidate
          (tutcode-make-string (tutcode-context-head pc)) "" ""
          (tutcode-context-nth pc) #f)
        (if (> (tutcode-context-nth pc) 0)
          (tutcode-save-personal-dictionary))))
    (tutcode-flush pc)
    res))

;;; ꤵ줿٥ʸбꤹ
(define (tutcode-commit-by-label-key pc ch)
  (let* ((nr (tutcode-context-nr-candidates pc))
         (nth (tutcode-context-nth pc))
         (cur-page (cond
                     ((= tutcode-nr-candidate-max 0) 0)
                     (else
                       (quotient nth tutcode-nr-candidate-max))))
         (cur-offset (* cur-page tutcode-nr-candidate-max))
         (cur-labels (list-tail
                       tutcode-heading-label-char-list
                       (remainder cur-offset
                                  (length tutcode-heading-label-char-list))))
         (target-labels (member ch cur-labels))
         (offset (if target-labels
                   (- (length cur-labels) (length target-labels))
                   (+ (length cur-labels)
                      (- (length tutcode-heading-label-char-list)
                         (length
                           (member ch tutcode-heading-label-char-list))))))
         (idx (+ cur-offset offset)))
    (if (and (>= idx 0)
             (< idx nr))
      (begin
        (tutcode-context-set-nth! pc idx)
        (im-commit pc (tutcode-prepare-commit-string pc))))))

;;; 򤼽Ѵɤ/Ѵ(ʸꥹhead)ʸɲä롣
;;; @param pc ƥȥꥹ
;;; @param str ɲäʸ
(define (tutcode-append-string pc str)
  (if (and str (string? str))
    (tutcode-context-set-head! pc
      (cons str
        (tutcode-context-head pc)))))

;;; 򤼽񤭼θԤ
;;; @param pc ƥȥꥹ
(define (tutcode-begin-conversion pc)
  (let* ((yomi (tutcode-make-string (tutcode-context-head pc)))
         (res (skk-lib-get-entry yomi "" "" #f)))
    (if res
      (begin
        (tutcode-context-set-nth! pc 0)
        (tutcode-context-set-nr-candidates! pc
         (skk-lib-get-nr-candidates yomi "" "" #f))
        (tutcode-context-set-state! pc 'tutcode-state-converting)
        (if (= (tutcode-context-nr-candidates pc) 1)
          ;; 䤬1ĤʤϼưŪ˳ꤹ
          (im-commit pc (tutcode-prepare-commit-string pc))
          (begin
            (tutcode-check-candidate-window-begin pc)
            (if (tutcode-context-candidate-window pc)
              (im-select-candidate pc 0)))))
      ;(tutcode-flush pc) ; ̵flushϤʸ󤬾äƤä
      )))

;;; 䥦ɥɽ򳫻Ϥ
(define (tutcode-check-candidate-window-begin pc)
  (if (and (not (tutcode-context-candidate-window pc))
           tutcode-use-candidate-window?
           (>= (tutcode-context-nth pc) (- tutcode-candidate-op-count 1)))
    (begin
      (tutcode-context-set-candidate-window! pc #t)
      (im-activate-candidate-selector
        pc
        (tutcode-context-nr-candidates pc)
        tutcode-nr-candidate-max))))

;;; preeditɽ򹹿롣
;;; @param pc ƥȥꥹ
(define (tutcode-update-preedit pc)
  (let ((stat (tutcode-context-state pc)))
    (im-clear-preedit pc)
    (case stat
      ((tutcode-state-yomi)
        (im-pushback-preedit pc preedit-none "")
        (let ((h (tutcode-make-string (tutcode-context-head pc))))
          (if (string? h)
            (im-pushback-preedit pc preedit-none h))))
      ((tutcode-state-converting)
        (im-pushback-preedit pc preedit-none "")
        (im-pushback-preedit pc preedit-none
          (tutcode-get-current-candidate pc)))
      ;; ѴΥޡʸȤheadǴ(ƵŪΤ)
      ((tutcode-state-bushu)
        (let ((h (tutcode-make-string (tutcode-context-head pc))))
          (if (string? h)
            (im-pushback-preedit pc preedit-none h)))))
    (im-pushback-preedit pc preedit-cursor "")
    (im-update-preedit pc)))

;;; TUT-CodeϾ֤ΤȤΥϤ롣
;;; @param pc ƥȥꥹ
;;; @param key Ϥ줿
;;; @param key-state ȥ륭ξ
(define (tutcode-proc-state-on pc key key-state)
  (let ((rkc (tutcode-context-rk-context pc)))
    (cond
      ((and
        (tutcode-vi-escape-key? key key-state)
        tutcode-use-with-vi?)
       (rk-flush rkc)
       (tutcode-context-set-state! pc 'tutcode-state-off)
       (im-commit-raw pc)) ; ESC򥢥ץˤϤ
      ((tutcode-off-key? key key-state)
       (rk-flush rkc)
       (tutcode-context-set-state! pc 'tutcode-state-off))
      ((tutcode-kana-toggle-key? key key-state)
       (rk-flush rkc)
       (tutcode-context-kana-toggle pc))
      ((tutcode-backspace-key? key key-state)
       (if (> (length (rk-context-seq rkc)) 0)
         (rk-flush rkc)
         (im-commit-raw pc)))
      ((or
        (symbol? key)
        (and
          (modifier-key-mask key-state)
          (not (shift-key-mask key-state))))
       (rk-flush rkc)
       (im-commit-raw pc))
      ;; ʤ󥹤ƼΤƤ(tc2˹碌ư)
      ;; (rk-push-key!ȡޤǤΥ󥹤ϼΤƤ뤬
      ;; ְäϻĤäƤޤΤǡrk-push-key!ϻȤʤ)
      ((not (member (charcode->string key) (rk-expect rkc)))
       (if (> (length (rk-context-seq rkc)) 0)
         (rk-flush rkc) ; ʤ󥹤ϼΤƤ
         (im-commit-raw pc))) ; ñȤΥ(TUT-CodeϤǤʤ)
      (else
       (let ((res (tutcode-push-key! pc (charcode->string key))))
         (if res
           (case res
            ((tutcode-mazegaki-start)
              (tutcode-context-set-state! pc 'tutcode-state-yomi))
            ((tutcode-bushu-start)
              (tutcode-context-set-state! pc 'tutcode-state-bushu)
              (tutcode-append-string pc ""))
            (else
              (im-commit pc res)))))))))

;;; ľϾ֤ΤȤΥϤ롣
;;; @param pc ƥȥꥹ
;;; @param key Ϥ줿
;;; @param key-state ȥ륭ξ
(define (tutcode-proc-state-off pc key key-state)
  (if
   (tutcode-on-key? key key-state)
   (tutcode-context-set-state! pc 'tutcode-state-on)
   (im-commit-raw pc)))

;;; 򤼽ѴɤϾ֤ΤȤΥϤ롣
;;; @param pc ƥȥꥹ
;;; @param key Ϥ줿
;;; @param key-state ȥ륭ξ
(define (tutcode-proc-state-yomi pc key key-state)
  (let* ((rkc (tutcode-context-rk-context pc))
         (res #f))
    (cond
      ((tutcode-off-key? key key-state)
       (tutcode-flush pc)
       (tutcode-context-set-state! pc 'tutcode-state-off))
      ((tutcode-kana-toggle-key? key key-state)
       (rk-flush rkc)
       (tutcode-context-kana-toggle pc))
      ((tutcode-backspace-key? key key-state)
       (if (> (length (rk-context-seq rkc)) 0)
        (rk-flush rkc)
        (if (> (length (tutcode-context-head pc)) 0)
          (tutcode-context-set-head! pc (cdr (tutcode-context-head pc))))))
      ((or
        (tutcode-commit-key? key key-state)
        (tutcode-return-key? key key-state))
       (im-commit pc (tutcode-make-string (tutcode-context-head pc)))
       (tutcode-flush pc))
      ((tutcode-cancel-key? key key-state)
       (tutcode-flush pc))
      ((symbol? key)
       (tutcode-flush pc)
       (tutcode-proc-state-on pc key key-state))
      ((and
        (modifier-key-mask key-state)
        (not (shift-key-mask key-state)))
       ;; <Control>nǤѴ?
       (if (tutcode-begin-conv-key? key key-state)
         (if (not (null? (tutcode-context-head pc)))
           (tutcode-begin-conversion pc)
           (tutcode-flush pc))
         (begin
           (tutcode-flush pc)
           (tutcode-proc-state-on pc key key-state))))
      ((not (member (charcode->string key) (rk-expect rkc)))
       (if (> (length (rk-context-seq rkc)) 0)
         (rk-flush rkc)
         ;; spaceǤѴ?
         ;; (spaceϥ󥹤˴ޤޤ礬Τǡ
         ;;  rk-expectspace̵Ȥ)
         ;; (trycodespaceǻϤޤ륭󥹤ȤäƤ硢
         ;;  spaceѴϤϤǤʤΤǡ<Control>nȤɬפ)
         (if (tutcode-begin-conv-key? key key-state)
           (if (not (null? (tutcode-context-head pc)))
             (tutcode-begin-conversion pc)
             (tutcode-flush pc))
           (set! res (charcode->string key)))))
      (else
       (set! res (tutcode-push-key! pc (charcode->string key)))))
    (if res
      (tutcode-append-string pc res))))

;;; ѴϾ֤ΤȤΥϤ롣
;;; @param pc ƥȥꥹ
;;; @param key Ϥ줿
;;; @param key-state ȥ륭ξ
(define (tutcode-proc-state-bushu pc key key-state)
  (let* ((rkc (tutcode-context-rk-context pc))
         (res #f))
    (cond
      ((tutcode-off-key? key key-state)
       (tutcode-flush pc)
       (tutcode-context-set-state! pc 'tutcode-state-off))
      ((tutcode-kana-toggle-key? key key-state)
       (rk-flush rkc)
       (tutcode-context-kana-toggle pc))
      ((tutcode-backspace-key? key key-state)
       (if (> (length (rk-context-seq rkc)) 0)
        (rk-flush rkc)
        ;; head1ʸܤѴΥޡbackspaceǤϾäʤ褦
        ;; 롣ְäƳѤʸäʤ褦ˤ뤿ᡣ
        (if (> (length (tutcode-context-head pc)) 1)
          (tutcode-context-set-head! pc (cdr (tutcode-context-head pc))))))
      ((or
        (tutcode-commit-key? key key-state)
        (tutcode-return-key? key key-state))
        ;; ƵŪѴ(ꤷ)᤹
        (set! res (car (tutcode-context-head pc)))
        (tutcode-context-set-head! pc (cdr (tutcode-context-head pc)))
        (if (not (string=? res ""))
          ;; ⤦1ʸ(ΤϤ)äơä
          (tutcode-context-set-head! pc (cdr (tutcode-context-head pc)))
          (set! res #f))
        (if (= (length (tutcode-context-head pc)) 0)
          (begin
            ;; Ǿ̤Ѵξ硢Ѵ󤬤commit
            (if res
              (im-commit pc res))
            (tutcode-flush pc)
            (set! res #f))))
      ((tutcode-cancel-key? key key-state)
        ;; ƵŪѴ(󥻥뤷)᤹
        (set! res (car (tutcode-context-head pc)))
        (tutcode-context-set-head! pc (cdr (tutcode-context-head pc)))
        (if (not (string=? res ""))
          ;; ⤦1ʸ(ΤϤ)äơä
          (tutcode-context-set-head! pc (cdr (tutcode-context-head pc))))
        (set! res #f)
        (if (= (length (tutcode-context-head pc)) 0)
          (tutcode-flush pc)))
      ((or
        (symbol? key)
        (and
          (modifier-key-mask key-state)
          (not (shift-key-mask key-state))))
       (tutcode-flush pc)
       (tutcode-proc-state-on pc key key-state))
      ((not (member (charcode->string key) (rk-expect rkc)))
       (if (> (length (rk-context-seq rkc)) 0)
         (rk-flush rkc)
         (set! res (charcode->string key))))
      (else
       (set! res (tutcode-push-key! pc (charcode->string key)))
       (case res
        ((tutcode-mazegaki-start) ; Ѵϸ򤼽Ѵ̵ˤ
          (set! res #f))
        ((tutcode-bushu-start) ; ƵŪѴ
          (tutcode-append-string pc "")
          (set! res #f)))))
    (if res
      (let loop ((prevchar (car (tutcode-context-head pc)))
                  (char res))
        (if (string=? prevchar "")
          (tutcode-append-string pc char)
          ;; ľʸޡǤʤ2ʸܤϤ줿Ѵ
          (begin
            (set! char
              (tutcode-bushu-convert prevchar char))
            (if (string? char)
              ;; 
              (begin
                ;; 1ܤȢä
                (tutcode-context-set-head! pc (cddr (tutcode-context-head pc)))
                (if (= (length (tutcode-context-head pc)) 0)
                  ;; ѴԤ󤬻ĤäƤʤСꤷƽλ
                  (begin
                    (im-commit pc char)
                    (tutcode-flush pc))
                  ;; 󤬤ޤĤäƤСƳǧ
                  ;; (ʸ2ʸܤʤСϢ³Ѵ)
                  (loop
                    (car (tutcode-context-head pc))
                    char)))
              ;; ԻϤľԤ
              )))))))

;;; 򤹤
;;; @param pc ƥȥꥹ
;;; @param num ߤθֹ椫鿷ֹޤǤΥեå
(define (tutcode-change-candidate-index pc num)
  (let* ((nr (tutcode-context-nr-candidates pc))
         (nth (tutcode-context-nth pc))
         (new-nth (+ nth num)))
    (cond
      ((< new-nth 0)
       (set! new-nth 0))
      ((>= new-nth nr)
       (set! new-nth (- nr 1))))
    (tutcode-context-set-nth! pc new-nth))
  (tutcode-check-candidate-window-begin pc)
  (if (tutcode-context-candidate-window pc)
    (im-select-candidate pc (tutcode-context-nth pc))))

;;; 䥦ɥĤ
(define (tutcode-reset-candidate-window pc)
  (if (tutcode-context-candidate-window pc)
    (begin
      (im-deactivate-candidate-selector pc)
      (tutcode-context-set-candidate-window! pc #f))))

;;; 򤼽Ѵθ֤顢ɤϾ֤᤹
;;; @param pc ƥȥꥹ
(define (tutcode-back-to-yomi-state pc)
  (tutcode-reset-candidate-window pc)
  (tutcode-context-set-state! pc 'tutcode-state-yomi)
  (tutcode-context-set-nr-candidates! pc 0))

;;; Ϥ줿٥ʸɤĴ٤
;;; @param key Ϥ줿
(define (tutcode-heading-label-char? key)
  (member (charcode->string key) tutcode-heading-label-char-list))

;;; 򤼽Ѵθ֤ΤȤΥϤ롣
;;; @param pc ƥȥꥹ
;;; @param key Ϥ줿
;;; @param key-state ȥ륭ξ
(define (tutcode-proc-state-converting pc key key-state)
  (cond
    ((tutcode-next-candidate-key? key key-state)
      (tutcode-change-candidate-index pc 1))
    ((tutcode-prev-candidate-key? key key-state)
      (tutcode-change-candidate-index pc -1))
    ((tutcode-cancel-key? key key-state)
      (tutcode-back-to-yomi-state pc))
    ((tutcode-next-page-key? key key-state)
      (tutcode-change-candidate-index pc tutcode-nr-candidate-max))
    ((tutcode-prev-page-key? key key-state)
      (tutcode-change-candidate-index pc (- tutcode-nr-candidate-max)))
    ((or
      (tutcode-commit-key? key key-state)
      (tutcode-return-key? key key-state))
      (im-commit pc (tutcode-prepare-commit-string pc)))
    ((and tutcode-commit-candidate-by-label-key?
          (tutcode-heading-label-char? key))
      (tutcode-commit-by-label-key pc (charcode->string key)))
    (else
      (im-commit pc (tutcode-prepare-commit-string pc))
      (tutcode-proc-state-on pc key key-state))))

;;; ѴԤ
;;; @param c1 1ܤ
;;; @param c2 2ܤ
;;; @return ʸǤʤäȤ#f
(define (tutcode-bushu-convert c1 c2)
  ;; tc-2.1+[tcode-ml:1925]르ꥺ
  (and c1 c2
    (or
      (tutcode-bushu-compose-sub c1 c2)
      (let ((a1 (tutcode-bushu-alternative c1))
            (a2 (tutcode-bushu-alternative c2)))
        (and
          (or
            (not (string=? a1 c1))
            (not (string=? a2 c2)))
          (begin
            (set! c1 a1)
            (set! c2 a2)
            #t)
          (tutcode-bushu-compose-sub c1 c2)))
      (let* ((decomposed1 (tutcode-bushu-decompose c1))
             (decomposed2 (tutcode-bushu-decompose c2))
             (tc11 (and decomposed1 (car decomposed1)))
             (tc12 (and decomposed1 (cadr decomposed1)))
             (tc21 (and decomposed2 (car decomposed2)))
             (tc22 (and decomposed2 (cadr decomposed2)))
             ;; ʸ2ĤȤϰۤʤ
             ;; ʸǤ뤳Ȥǧ롣
             ;; (string=?#fäȤ˥顼ˤʤΤequal?)
             (newchar
                (lambda (new)
                  (and
                    (not (equal? new c1))
                    (not (equal? new c2))
                    new))))
        (or
          ;; 
          (and
            (equal? tc11 c2)
            (newchar tc12))
          (and
            (equal? tc12 c2)
            (newchar tc11))
          (and
            (equal? tc21 c1)
            (newchar tc22))
          (and
            (equal? tc22 c1)
            (newchar tc21))
          ;; ʤˤ­
          (let ((compose-newchar
                  (lambda (i1 i2)
                    (let ((res (tutcode-bushu-compose-sub i1 i2)))
                      (and res
                        (newchar res))))))
            (or
              (compose-newchar c1 tc22) (compose-newchar tc11 c2)
              (compose-newchar c1 tc21) (compose-newchar tc12 c2)
              (compose-newchar tc11 tc22) (compose-newchar tc11 tc21)
              (compose-newchar tc12 tc22) (compose-newchar tc12 tc21)))
          ;; ʤˤ
          (and tc11
            (equal? tc11 tc21)
            (newchar tc12))
          (and tc11
            (equal? tc11 tc22)
            (newchar tc12))
          (and tc12
            (equal? tc12 tc21)
            (newchar tc11))
          (and tc12
            (equal? tc12 tc22)
            (newchar tc11)))))))

;;; Ѵ:c1c2ƤǤʸõ֤
;;; ꤵ줿֤ǸĤʤäϡ֤줫õ
;;; @param c1 1ܤ
;;; @param c2 2ܤ
;;; @return ʸǤʤäȤ#f
(define (tutcode-bushu-compose-sub c1 c2)
  (and c1 c2
    (or
      (tutcode-bushu-compose c1 c2)
      (tutcode-bushu-compose c2 c1))))

;;; Ѵ:c1c2ƤǤʸõ֤
;;; @param c1 1ܤ
;;; @param c2 2ܤ
;;; @return ʸǤʤäȤ#f
(define (tutcode-bushu-compose c1 c2)
  (let ((seq (rk-lib-find-seq (list c1 c2) tutcode-bushudic)))
    (and seq
      (car (cadr seq)))))

;;; Ѵ:ʸõ֤
;;; @param c оݤʸ
;;; @return ʸʸĤʤäȤϸʸ
(define (tutcode-bushu-alternative c)
  (let ((alt (assoc c tutcode-bushudic-altchar)))
    (or
      (and alt (cadr alt))
      c)))

;;; Ѵ:ʸ2Ĥʬ򤹤롣
;;; @param c ʬоݤʸ
;;; @return ʬ򤷤ƤǤ2ĤΥꥹȡʬǤʤäȤ#f
(define (tutcode-bushu-decompose c)
  (let ((lst
          (filter
            (lambda (elem)
              (string=? c (car (cadr elem))))
            tutcode-bushudic)))
    (and
      (not (null? lst))
      (car (caar lst)))))

;;; ߤstatepreeditĤɤ֤
;;; @param pc ƥȥꥹ
(define (tutcode-state-has-preedit? pc)
  (memq (tutcode-context-state pc)
    '(tutcode-state-yomi tutcode-state-bushu tutcode-state-converting)))

;;; 줿ȤνοʬԤ
;;; @param pc ƥȥꥹ
;;; @param key Ϥ줿
;;; @param key-state ȥ륭ξ
(define (tutcode-key-press-handler pc key key-state)
  (if (ichar-control? key)
      (im-commit-raw pc)
      (begin
        (case (tutcode-context-state pc)
          ((tutcode-state-on)
           (tutcode-proc-state-on pc key key-state)
           (if (tutcode-state-has-preedit? pc)
             ;; 򤼽ѴѴϡ䢥ɽ
             (tutcode-update-preedit pc)))
          ((tutcode-state-yomi)
           (tutcode-proc-state-yomi pc key key-state)
           (tutcode-update-preedit pc))
          ((tutcode-state-converting)
           (tutcode-proc-state-converting pc key key-state)
           (tutcode-update-preedit pc))
          ((tutcode-state-bushu)
           (tutcode-proc-state-bushu pc key key-state)
           (tutcode-update-preedit pc))
          (else
           (tutcode-proc-state-off pc key key-state))))))

;;; Υ줿ȤνԤ
;;; @param pc ƥȥꥹ
;;; @param key Ϥ줿
;;; @param key-state ȥ륭ξ
(define (tutcode-key-release-handler pc key key-state)
  (if (or (ichar-control? key)
	  (not (tutcode-context-on? pc)))
      ;; don't discard key release event for apps
      (im-commit-raw pc)))

;;; TUT-Code IMνԤ
(define (tutcode-init-handler id im arg)
  (tutcode-context-new id im))

(define (tutcode-release-handler pc)
  (tutcode-save-personal-dictionary))

(define (tutcode-reset-handler tc)
  (tutcode-flush tc))

(define (tutcode-focus-in-handler tc) #f)

(define (tutcode-focus-out-handler tc)
  (let ((rkc (tutcode-context-rk-context tc)))
    (rk-flush rkc)))

(define tutcode-place-handler tutcode-focus-in-handler)
(define tutcode-displace-handler tutcode-focus-out-handler)

;;; 䥦ɥʸ뤿˸Ƥִؿ
(define (tutcode-get-candidate-handler tc idx accel-enum-hint)
  (let ((cand (tutcode-get-nth-candidate tc idx))
        (n (remainder idx (length tutcode-heading-label-char-list))))
    (list cand (nth n tutcode-heading-label-char-list) "")))

;;; 䥦ɥ򤷤Ȥ˸Ƥִؿ
(define (tutcode-set-candidate-index-handler tc idx)
  (if (tutcode-context-candidate-window tc)
    (begin
      (tutcode-context-set-nth! tc idx)
      (tutcode-update-preedit tc))))

(tutcode-configure-widgets)

;;; TUT-Code IMϿ롣
(register-im
 'tutcode
 "ja"
 "EUC-JP"
 (N_ "TUT-Code")
 (N_ "A kanji direct input method")
 #f
 tutcode-init-handler
 tutcode-release-handler
 context-mode-handler
 tutcode-key-press-handler
 tutcode-key-release-handler
 tutcode-reset-handler
 tutcode-get-candidate-handler
 tutcode-set-candidate-index-handler
 context-prop-activate-handler
 #f
 tutcode-focus-in-handler
 tutcode-focus-out-handler
 tutcode-place-handler
 tutcode-displace-handler
 )

;;; ɽQwertyDvorakѤѴ롣
;;; @param qwerty QwertyΥɽ
;;; @return DvorakѴɽ
(define (tutcode-rule-qwerty-to-dvorak qwerty)
  (map
    (lambda (elem)
      (cons
        (list
          (map
            (lambda (key)
              (cadr (assoc key tutcode-rule-qwerty-to-dvorak-alist)))
            (caar elem)))
        (cdr elem)))
    qwerty))

;;; QwertyDvorakؤѴơ֥롣
(define tutcode-rule-qwerty-to-dvorak-alist
  '(
    ;ľǻȤʳϥȥ
    ("1" "1")
    ("2" "2")
    ("3" "3")
    ("4" "4")
    ("5" "5")
    ("6" "6")
    ("7" "7")
    ("8" "8")
    ("9" "9")
    ("0" "0")
    ;("-" "[")
    ;("^" "]") ;106
    ("q" "'")
    ("w" ",")
    ("e" ".")
    ("r" "p")
    ("t" "y")
    ("y" "f")
    ("u" "g")
    ("i" "c")
    ("o" "r")
    ("p" "l")
    ;("@" "/") ;106
    ;("[" "=") ;106
    ("a" "a")
    ("s" "o")
    ("d" "e")
    ("f" "u")
    ("g" "i")
    ("h" "d")
    ("j" "h")
    ("k" "t")
    ("l" "n")
    (";" "s")
    ;(":" "-") ;106
    ("z" ";")
    ("x" "q")
    ("c" "j")
    ("v" "k")
    ("b" "x")
    ("n" "b")
    ("m" "m")
    ("," "w")
    ("." "v")
    ("/" "z")
    ;; shift
    ;("\"" "@") ;106
    ;("&" "^") ;106
    ;("'" "&") ;106
    ;("(" "*") ;106
    ;(")" "(") ;106
    ;("=" "{") ;106
    ;("~" "}") ;106
    ("Q" "\"")
    ("W" "<")
    ("E" ">")
    ("R" "P")
    ("T" "Y")
    ("Y" "F")
    ("U" "G")
    ("I" "C")
    ("O" "R")
    ("P" "L")
    ;("`" "?") ;106
    ;("{" "+") ;106
    ("A" "A")
    ("S" "O")
    ("D" "E")
    ("F" "U")
    ("G" "I")
    ("H" "D")
    ("J" "H")
    ("K" "T")
    ("L" "N")
    ("+" "S") ;106
    ;("*" "_") ;106
    ("Z" ":")
    ("X" "Q")
    ("C" "J")
    ("V" "K")
    ("B" "X")
    ("N" "B")
    ("M" "M")
    ("<" "W")
    (">" "V")
    ("?" "Z")
    (" " " ")
    ))

;;; tutcode-customꤵ줿ɽΥե̾饳ɽ̾äơ
;;; Ѥ륳ɽȤꤹ롣
;;; 륳ɽ̾ϡե̾".scm"򤱤äơ
;;; "-rule"ĤƤʤäɲäΡ
;;; : "tutcode-rule.scm"tutcode-rule
;;;     "tcode.scm"tcode-rule
;;; @param filename tutcode-rule-filename
(define (tutcode-custom-load-rule! filename)
  (and
    (try-load filename)
    (let*
      ((basename (last (string-split filename "/")))
       ;; ե̾".scm"򤱤
       (bnlist (string-to-list basename))
       (codename
        (or
          (and
            (> (length bnlist) 4)
            (string=? (string-list-concat (list-head bnlist 4)) ".scm")
            (string-list-concat (list-tail bnlist 4)))
          basename))
       ;; "-rule"ĤƤʤäɲ
       (rulename
        (or
          (and
            (not (string=? (last (string-split codename "-")) "rule"))
            (string-append codename "-rule"))
          codename)))
      (and rulename
        (symbol-bound? (string->symbol rulename))
        (set! tutcode-rule
          (eval (string->symbol rulename) (interaction-environment)))))))

;;; tutcode-key-customꤵ줿򤼽/ѴϤΥ󥹤
;;; ɽȿǤ
(define (tutcode-custom-set-mazegaki/bushu-start-sequence!)
  (let*
    ((make-subrule
      (lambda (keyseq cmd)
        (if
          (and
            keyseq
            (> (string-length keyseq) 0))
          (let ((keys (reverse (string-to-list keyseq))))
            (list (list (list keys) cmd)))
          #f)))
     (subrule ()))
    (set! subrule
      (make-subrule tutcode-mazegaki-start-sequence '(tutcode-mazegaki-start)))
    (set! subrule
      (append subrule
        (make-subrule tutcode-bushu-start-sequence '(tutcode-bushu-start))))
    (tutcode-rule-set-sequences! subrule)))

;;; ɽΰѹ/ɲä롣~/.uimλѤꡣ
;;; ƤӽФˤtutcode-rule-userconfigϿƤǡ
;;; ºݤ˥ɽȿǤΤϡtutcode-context-new
;;;
;;; (tutcode-rule-filename꤬uim-pref~/.uimΤɤǹԤ줿Ǥ
;;;  ~/.uimǤΥɽΰѹƱҤǤǤ褦ˤ뤿ᡣ
;;;  ɽɸhookѰդ)
;;;
;;; ƤӽФ:
;;;   (tutcode-rule-set-sequences!
;;;     '(((("d" "l" "u")) ("" ""))
;;;       ((("d" "l" "d" "u")) ("" ""))))
;;; @param rules 󥹤ϤʸΥꥹ
(define (tutcode-rule-set-sequences! rules)
  (set! tutcode-rule-userconfig
    (append rules tutcode-rule-userconfig)))

;;; ɽξѹ/ɲäΤtutcode-rule-userconfig
;;; ɽȿǤ롣
(define (tutcode-rule-commit-sequences! rules)
  ;; ɽθϥ˥˹ԤΤǡꥹȤƬǾ񤭤OK
  (if (not (null? rules))
    (set! tutcode-rule (append rules tutcode-rule))))