Revision: 7254
Author: deton.kih
Date: Thu Aug 4 19:56:13 2011
Log: * Add kanji code input mode to uim-skk.
* scm/skk.scm
- (skk-do-update-preedit): Change for kanji code input mode.
- (skk-proc-state-direct-no-preedit): Add check of skk-kcode-input-key.
- (skk-proc-state-direct): Change for kanji code input mode.
- (skk-proc-state-kcode): New.
- (skk-push-key): Add call of skk-proc-state-kcode.
* scm/skk-key-custom.scm
- (skk-kcode-input-key): New custom key.
* scm/japanese.scm
- (ja-euc-jp-code->euc-jp-string,
ja-jis-code->euc-jp-string,
ja-kanji-code-input-jis,
ja-kanji-code-input-kuten,
ja-kanji-code-input-ucs):
Move from tutcode.scm and rename from tutcode-XXX to ja-XXX.
* scm/tutcode.scm
- (tutcode-kanji-code-input-ucs,
tutcode-kanji-code-input-kuten,
tutcode-kanji-code-input-jis,
tutcode-jis-code->euc-jp-string,
tutcode-euc-jp-code->euc-jp-string):
Move to japanese.scm and rename from tutcode-XXX to ja-XXX.
- (tutcode-begin-kanji-code-input): Follow the rename.
http://code.google.com/p/uim/source/detail?r=7254
Modified:
/trunk/scm/japanese.scm
/trunk/scm/skk-key-custom.scm
/trunk/scm/skk.scm
/trunk/scm/tutcode.scm
=======================================
--- /trunk/scm/japanese.scm Thu Jan 6 18:09:56 2011
+++ /trunk/scm/japanese.scm Thu Aug 4 19:56:13 2011
@@ -30,6 +30,7 @@
;; Japanese EUC
+(require-extension (srfi 1 2))
(require-custom "japanese-custom.scm")
(define ja-rk-rule-basic
@@ -930,6 +931,77 @@
(set! ja-rk-rule (append ja-rk-rule-basic
ja-rk-rule-additional)))))
+
+;;; Convert EUC-JP code to EUC-JP string (cf. ucs->utf8-string in
ichar.scm)
+(define (ja-euc-jp-code->euc-jp-string code)
+ (with-char-codec "EUC-JP"
+ (lambda ()
+ (let ((str (list->string (list (integer->char code)))))
+ (with-char-codec "ISO-8859-1"
+ (lambda ()
+ (%%string-reconstruct! str)))))))
+
+;;; Convert JIS code(ISO-2022-JP) to EUC-JP string
+(define (ja-jis-code->euc-jp-string state jis1 jis2)
+ (let
+ ((ej0 (if (eq? state 'jisx0213-plane2) #x8f 0))
+ (ej1 (+ jis1 #x80))
+ (ej2 (+ jis2 #x80)))
+ (and
+ ;; sigscheme/src/encoding.c:eucjp_int2str()
+ (<= #xa1 ej1 #xfe) ; IN_GR94()
+ (if (= ej0 #x8f) ; SS3?
+ (<= #xa1 ej2 #xfe) ; IN_GR94()
+ (<= #xa0 ej2 #xff)) ; IN_GR96()
+ (ja-euc-jp-code->euc-jp-string
+ (+ (* ej0 #x10000) (* ej1 #x100) ej2)))))
+
+;;; Convert reverse string list of JIS code to one EUC-JP kanji string
+;;; ("d" "2" "0" "5") -> "Ð"
+(define (ja-kanji-code-input-jis str-list)
+ (and-let*
+ ((length=4? (= (length str-list) 4))
+ (str1 (string-list-concat (take-right str-list 2)))
+ (str2 (string-list-concat (take str-list 2)))
+ (jis1 (string->number str1 16))
+ (jis2 (string->number str2 16)))
+ (ja-jis-code->euc-jp-string 'jisx0213-plane1 jis1 jis2)))
+
+;;; Convert reverse string list of Kuten code to one EUC-JP kanji string
+;;; ("3" "1" "-" "8" "4" "-" "1") -> "Ð"
+(define (ja-kanji-code-input-kuten str-list)
+ (let*
+ ((numlist (string-split (string-list-concat str-list) "-"))
+ (men-exists? (>= (length numlist) 3))
+ (men (if men-exists? (string->number (list-ref numlist 0)) 1))
+ (ku (string->number (list-ref numlist (if men-exists? 1 0))))
+ (ten (string->number (list-ref numlist (if men-exists? 2 1)))))
+ (and men ku ten (<= 1 men 2)
+ (ja-jis-code->euc-jp-string
+ (if (= men 2) 'jisx0213-plane2 'jisx0213-plane1)
+ (+ ku #x20) (+ ten #x20)))))
+
+;;; Convert reverse string list of UCS to one EUC-JP kanji string
+;;; ("5" "8" "E" "4" "+" "U") -> "Ð"
+(define (ja-kanji-code-input-ucs str-list)
+ (and-let*
+ ((str-list-1 (drop-right str-list 1)) ; drop last "U"
+ (not-only-u? (not (null? str-list-1)))
+ (ucs-str (if (string=? (last str-list-1) "+")
+ (drop-right str-list-1 1)
+ str-list-1))
+ (ucs (string->number (string-list-concat ucs-str) 16))
+ ;; range check to avoid error
+ (valid? ; sigscheme/src/sigschemeinternal.h:ICHAR_VALID_UNICODEP()
+ (or
+ (<= 0 ucs #xd7ff)
+ (<= #xe000 ucs #x10ffff)))
+ (utf8-str (ucs->utf8-string ucs))
+ (ic (iconv-open "EUC-JP" "UTF-8")))
+ (let ((eucj-str (iconv-code-conv ic utf8-str)))
+ (iconv-release ic)
+ eucj-str)))
+
;;
(require "rk.scm")
=======================================
--- /trunk/scm/skk-key-custom.scm Thu Jan 6 18:09:56 2011
+++ /trunk/scm/skk-key-custom.scm Thu Aug 4 19:56:13 2011
@@ -104,6 +104,12 @@
(N_ "[SKK] wide-latin mode")
(N_ "long description will be here"))
+(define-custom 'skk-kcode-input-key '("yen")
+ '(skk-keys1 mode-transition)
+ '(key)
+ (N_ "[SKK] kanji code input mode")
+ (N_ "long description will be here"))
+
(define-custom 'skk-kanji-mode-key '("<IgnoreCase><Shift>q") ;; "Q"
'(skk-keys1 mode-transition)
'(key)
=======================================
--- /trunk/scm/skk.scm Thu Jan 6 18:09:56 2011
+++ /trunk/scm/skk.scm Thu Aug 4 19:56:13 2011
@@ -41,6 +41,7 @@
;; Á÷¤ê¤¬¤Ê okuri
;; 񥨓 latin
;; Á´³Ñ±Ñ¿ô wide-latin
+;; ´Á»ú¥³¡¼¥ÉÆþÎÏ kcode
;;
;;
(require "japanese.scm")
@@ -790,6 +791,10 @@
(eq? stat 'skk-state-completion)
(eq? stat 'skk-state-okuri)))
(im-pushback-preedit sc skk-preedit-attr-mode-mark "¢¦"))
+ (if (and
+ (null? csc)
+ (eq? stat 'skk-state-kcode))
+ (im-pushback-preedit sc skk-preedit-attr-mode-mark "JIS "))
(if (or
(not (null? csc))
(eq? stat 'skk-state-converting))
@@ -799,7 +804,8 @@
(null? csc)
(or
(eq? stat 'skk-state-kanji)
- (eq? stat 'skk-state-okuri)))
+ (eq? stat 'skk-state-okuri)
+ (eq? stat 'skk-state-kcode)))
(let ((h (skk-make-string
(skk-context-head sc)
(skk-context-kana-mode sc))))
@@ -928,7 +934,8 @@
(or
(eq? stat 'skk-state-kanji)
(eq? stat 'skk-state-completion)
- (eq? stat 'skk-state-okuri))
+ (eq? stat 'skk-state-okuri)
+ (eq? stat 'skk-state-kcode))
skk-show-cursor-on-preedit?
(not with-dcomp-word?))
(im-pushback-preedit sc preedit-cursor ""))))
@@ -1032,6 +1039,10 @@
(skk-context-set-state! sc 'skk-state-latin)
(rk-flush rkc)
#f)
+ ((skk-kcode-input-key? key key-state)
+ (skk-context-set-state! sc 'skk-state-kcode)
+ (rk-flush rkc)
+ #f)
((skk-latin-conv-key? key key-state)
(skk-context-set-state! sc 'skk-state-kanji)
(skk-context-set-latin-conv! sc #t)
@@ -1113,10 +1124,10 @@
(skk-commit-raw-with-preedit-update sc key key-state)
#f)
#t)
- ;; Handles "n{L,l,/,Q,C-q,C-Q,q}" key sequence as below. This is
+ ;; Handles "n{L,l,/,\,Q,C-q,C-Q,q}" key sequence as below. This is
;; ddskk-compatible behavior.
;; 1. commits "n" as kana according to kana-mode
- ;; 2. switch mode by "{L,l,/,Q,C-q,C-Q,q}"
+ ;; 2. switch mode by "{L,l,/,\,Q,C-q,C-Q,q}"
(if (and (skk-wide-latin-key? key key-state)
(not (rk-expect-key? rkc key-str)))
(begin
@@ -1131,6 +1142,13 @@
(skk-context-set-state! sc 'skk-state-latin)
#f)
#t)
+ (if (and (skk-kcode-input-key? key key-state)
+ (not (rk-expect-key? rkc key-str)))
+ (begin
+ (set! res (rk-push-key-last! rkc))
+ (skk-context-set-state! sc 'skk-state-kcode)
+ #f)
+ #t)
(if (and (skk-latin-conv-key? key key-state)
(not (rk-expect-key? rkc key-str)))
(let* ((residual-kana (rk-push-key-last! rkc)))
@@ -1234,7 +1252,8 @@
(if (or
(eq? (skk-context-state sc) 'skk-state-direct)
(eq? (skk-context-state sc) 'skk-state-latin)
- (eq? (skk-context-state sc) 'skk-state-wide-latin))
+ (eq? (skk-context-state sc) 'skk-state-wide-latin)
+ (eq? (skk-context-state sc) 'skk-state-kcode))
(if (and res
(or
(list? (car res))
@@ -2102,6 +2121,55 @@
(skk-commit-raw sc key key-state)))
#f)))
+(define skk-proc-state-kcode
+ (lambda (c key key-state)
+ (let ((sc (skk-find-descendant-context c)))
+ (and
+ (if (skk-cancel-key? key key-state)
+ (begin
+ (skk-flush sc)
+ #f)
+ #t)
+ (if (skk-backspace-key? key key-state)
+ (begin
+ (if (> (length (skk-context-head sc)) 0)
+ (skk-context-set-head! sc (cdr (skk-context-head sc)))
+ (skk-flush sc))
+ #f)
+ #t)
+ (if (or
+ (skk-commit-key? key key-state)
+ (skk-return-key? key key-state))
+ (begin
+ (if (> (length (skk-context-head sc)) 0)
+ (let* ((str-list (string-to-list
+ (skk-make-string
+ (skk-context-head sc)
+ (skk-context-kana-mode sc))))
+ (kanji
+ (cond
+ ((string-ci=? (last str-list) "u")
+ (ja-kanji-code-input-ucs str-list))
+ ((member "-" str-list)
+ (ja-kanji-code-input-kuten str-list))
+ (else
+ (ja-kanji-code-input-jis str-list)))))
+ (if (and kanji (> (string-length kanji) 0))
+ (begin
+ (skk-commit sc kanji)
+ (skk-flush sc))))
+ (skk-flush sc))
+ #f)
+ #t)
+ ;; append latin string
+ (if (ichar-graphic? key)
+ (let* ((s (charcode->string key))
+ (p (cons s (cons s (cons s s)))))
+ (skk-append-string sc p)
+ #f)
+ #t))
+ #f)))
+
(define skk-push-key
(lambda (c key key-state)
(let* ((sc (skk-find-descendant-context c))
@@ -2120,7 +2188,9 @@
((eq? state 'skk-state-latin)
skk-proc-state-latin)
((eq? state 'skk-state-wide-latin)
- skk-proc-state-wide-latin)))
+ skk-proc-state-wide-latin)
+ ((eq? state 'skk-state-kcode)
+ skk-proc-state-kcode)))
(res (fun c key key-state)))
(if res
(skk-commit sc res))
=======================================
--- /trunk/scm/tutcode.scm Wed Aug 3 17:40:14 2011
+++ /trunk/scm/tutcode.scm Thu Aug 4 19:56:13 2011
@@ -1552,96 +1552,17 @@
((kanji
(cond
((string-ci=? (last str-list) "u")
- (tutcode-kanji-code-input-ucs str-list))
+ (ja-kanji-code-input-ucs str-list))
((member "-" str-list)
- (tutcode-kanji-code-input-kuten str-list))
+ (ja-kanji-code-input-kuten str-list))
(else
- (tutcode-kanji-code-input-jis str-list)))))
+ (ja-kanji-code-input-jis str-list)))))
(if (and kanji (> (string-length kanji) 0))
(begin
(tutcode-commit pc kanji)
(tutcode-flush pc)
(tutcode-check-auto-help-window-begin pc (list kanji) ())))))
-;;; ÆþÎϤµ¤ì¤¿UCS¤ËÂбþ¤¹¤ë´Á»ú¤ò³ÎÄꤹ¤ë
-;;; @param str-list UCS(16¿Ê¿ô)¡£ÆþÎϤµ¤ì¤¿Ê¸»úÎó¤Î¥ê¥¹¥È(µÕ½ç)
-;;; @return EUC-JPʸ»úÎó¡£Àµ¤·¤¯¤Ê¤¤¥³¡¼¥É¤Î¾ì¹ç¤Ï#f
-(define (tutcode-kanji-code-input-ucs str-list)
- (and-let*
- ((str-list-1 (drop-right str-list 1)) ; drop last "U"
- (not-only-u? (not (null? str-list-1)))
- (ucs-str (if (string=? (last str-list-1) "+")
- (drop-right str-list-1 1)
- str-list-1))
- (ucs (string->number (string-list-concat ucs-str) 16))
- ;; ¥¨¥é¡¼²óÈò¤Î¤¿¤áÈÏ°Ï¥Á¥§¥Ã¥¯
- (valid? ; sigscheme/src/sigschemeinternal.h:ICHAR_VALID_UNICODEP()
- (or
- (<= 0 ucs #xd7ff)
- (<= #xe000 ucs #x10ffff)))
- (utf8-str (ucs->utf8-string ucs))
- (ic (iconv-open "EUC-JP" "UTF-8")))
- (let ((eucj-str (iconv-code-conv ic utf8-str)))
- (iconv-release ic)
- eucj-str)))
-
-;;; ÆþÎϤµ¤ì¤¿JIS X 0213¤Î(ÌÌ)¶èÅÀÈÖ¹æ¤ËÂбþ¤¹¤ë´Á»ú¤ò³ÎÄꤹ¤ë
-;;; @param str-list (ÌÌ)¶èÅÀÈֹ档ÆþÎϤµ¤ì¤¿Ê¸»úÎó¤Î¥ê¥¹¥È(µÕ½ç)
-;;; @return EUC-JPʸ»úÎó¡£Àµ¤·¤¯¤Ê¤¤ÈÖ¹æ¤Î¾ì¹ç¤Ï#f
-(define (tutcode-kanji-code-input-kuten str-list)
- (let*
- ((numlist (string-split (string-list-concat str-list) "-"))
- (men-exists? (>= (length numlist) 3))
- (men (if men-exists? (string->number (list-ref numlist 0)) 1))
- (ku (string->number (list-ref numlist (if men-exists? 1 0))))
- (ten (string->number (list-ref numlist (if men-exists? 2 1)))))
- (and men ku ten (<= 1 men 2)
- (tutcode-jis-code->euc-jp-string
- (if (= men 2) 'jisx0213-plane2 'jisx0213-plane1)
- (+ ku #x20) (+ ten #x20)))))
-
-;;; ÆþÎϤµ¤ì¤¿JIS¥³¡¼¥É(ISO-2022-JP)¤ËÂбþ¤¹¤ë´Á»ú¤ò³ÎÄꤹ¤ë
-;;; @param str-list JIS¥³¡¼¥É¡£ÆþÎϤµ¤ì¤¿Ê¸»úÎó¤Î¥ê¥¹¥È(µÕ½ç)
-;;; @return EUC-JPʸ»úÎó¡£Àµ¤·¤¯¤Ê¤¤¥³¡¼¥É¤Î¾ì¹ç¤Ï#f
-(define (tutcode-kanji-code-input-jis str-list)
- (and-let*
- ((length=4? (= (length str-list) 4))
- (str1 (string-list-concat (take-right str-list 2)))
- (str2 (string-list-concat (take str-list 2)))
- (jis1 (string->number str1 16))
- (jis2 (string->number str2 16)))
- (tutcode-jis-code->euc-jp-string 'jisx0213-plane1 jis1 jis2)))
-
-;;; JIS¥³¡¼¥É(ISO-2022-JP)¤òEUC-JPʸ»úÎó¤ËÊÑ´¹¤¹¤ë
-;;; @param state 'jisx0213-plane1¤«'jisx0213-plane2
-;;; @param jis1 JIS¥³¡¼¥É¤Î1¥Ð¥¤¥ÈÌÜ
-;;; @param jis2 JIS¥³¡¼¥É¤Î2¥Ð¥¤¥ÈÌÜ
-;;; @return EUC-JPʸ»úÎó¡£Àµ¤·¤¯¤Ê¤¤¥³¡¼¥É¤Î¾ì¹ç¤Ï#f
-(define (tutcode-jis-code->euc-jp-string state jis1 jis2)
- (let
- ((ej0 (if (eq? state 'jisx0213-plane2) #x8f 0))
- (ej1 (+ jis1 #x80))
- (ej2 (+ jis2 #x80)))
- (and
- ;; sigscheme/src/encoding.c:eucjp_int2str()
- (<= #xa1 ej1 #xfe) ; IN_GR94()
- (if (= ej0 #x8f) ; SS3?
- (<= #xa1 ej2 #xfe) ; IN_GR94()
- (<= #xa0 ej2 #xff)) ; IN_GR96()
- (tutcode-euc-jp-code->euc-jp-string
- (+ (* ej0 #x10000) (* ej1 #x100) ej2)))))
-
-;;; EUC-JP¥³¡¼¥É¤òEUC-JPʸ»úÎó¤ËÊÑ´¹¤¹¤ë (cf. ucs->utf8-string in
ichar.scm)
-;;; @param code EUC-JP¥³¡¼¥É
-;;; @return EUC-JPʸ»úÎó
-(define (tutcode-euc-jp-code->euc-jp-string code)
- (with-char-codec "EUC-JP"
- (lambda ()
- (let ((str (list->string (list (integer->char code)))))
- (with-char-codec "ISO-8859-1"
- (lambda ()
- (%%string-reconstruct! str)))))))
-
;;; »Ò¥³¥ó¥Æ¥¥¹¥È¤òºîÀ®¤¹¤ë¡£
;;; @param type 'tutcode-child-type-editor¤«'tutcode-child-type-dialog
(define (tutcode-setup-child-context pc type)
