1;;; yahoo-jp.scm: yahoo-jp for uim. 2;;; 3;;; Copyright (c) 2008-2013 uim Project https://github.com/uim/uim 4;;; 5;;; All rights reserved. 6;;; 7;;; Redistribution and use in source and binary forms, with or without 8;;; modification, are permitted provided that the following conditions 9;;; are met: 10;;; 1. Redistributions of source code must retain the above copyright 11;;; notice, this list of conditions and the following disclaimer. 12;;; 2. Redistributions in binary form must reproduce the above copyright 13;;; notice, this list of conditions and the following disclaimer in the 14;;; documentation and/or other materials provided with the distribution. 15;;; 3. Neither the name of authors nor the names of its contributors 16;;; may be used to endorse or promote products derived from this software 17;;; without specific prior written permission. 18;;; 19;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND 20;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 22;;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE 23;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 25;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 26;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 27;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 28;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 29;;; SUCH DAMAGE. 30;;;; 31 32(require-extension (srfi 1 2 6 23 34 48)) 33 34(require "ustr.scm") 35(require "japanese.scm") 36(require "http-client.scm") 37(require "generic-predict.scm") 38(require "util.scm") 39(require-custom "generic-key-custom.scm") 40(require-custom "yahoo-jp-custom.scm") 41(require-custom "yahoo-jp-key-custom.scm") 42 43(require-dynlib "expat") 44 45;;; implementations 46 47;; 48;; canna emulating functions 49;; 50 51(define yahoo-jp-internal-context-rec-spec 52 (append 53 context-rec-spec 54 (list 55 (list 'yomi-seg '()) 56 (list 'candidates '()) 57 (list 'seg-cnts '()) 58 (list 'prediction-word '()) 59 (list 'prediction-candidates '()) 60 (list 'prediction-appendix '()) 61 (list 'prediction-nr '())))) 62(define-record 'yahoo-jp-internal-context yahoo-jp-internal-context-rec-spec) 63(define yahoo-jp-internal-context-new-internal yahoo-jp-internal-context-new) 64 65(define (yahoo-jp-conversion str opts) 66 (define (fromconv str) 67 (iconv-convert "UTF-8" "EUC-JP" str)) 68 (define (toconv str) 69 (iconv-convert "EUC-JP" "UTF-8" str)) 70 (define (make-query appid) 71 (format "~aconversion?appid=~a&sentence=~a~a" 72 yahoo-jp-path 73 appid 74 (http:encode-uri-string (fromconv str)) 75 opts)) 76 (define (parse str) 77 (let ((parser (xml-parser-create "UTF-8")) 78 (path '()) 79 (seg '()) 80 (seg-txt "") 81 (candidate '()) 82 (cand-queue '())) 83 (define (elem-start name atts) 84 (set! path (append path (list name)))) 85 (define (elem-end name) 86 (cond ((equal? '("ResultSet" "Result" "SegmentList" "Segment" "CandidateList") 87 path) 88 (set! candidate (append candidate (list cand-queue))) 89 (set! cand-queue '())) 90 ((equal? '("ResultSet" "Result" "SegmentList" "Segment") 91 path) 92 (set! seg (append seg (list seg-txt))) 93 (set! seg-txt ""))) 94 (set! path (drop-right path 1))) 95 (define (chardata str) 96 (cond ((equal? '("ResultSet" "Result" "SegmentList" "Segment" "CandidateList" "Candidate") 97 path) 98 (set! cand-queue (append cand-queue (list (toconv str))))) 99 ((equal? '("ResultSet" "Result" "SegmentList" "Segment" "SegmentText") 100 path) 101 (set! seg-txt (toconv str))))) 102 (xml-element-handler-set! parser elem-start elem-end) 103 (xml-characterdata-handler-set! parser chardata) 104 (xml-parse parser str 1) 105 (xml-parser-free parser) 106 (cons seg candidate))) 107 108 (let* ((appid (if (string=? yahoo-jp-appid "") 109 (begin (uim-notify-fatal (N_ "Please regist Api key from <a href='http://developer.yahoo.co.jp/'>developer network</a> and set value on advanced menu.")) 110 #f) 111 yahoo-jp-appid)) 112 (proxy (make-http-proxy-from-custom)) 113 (ssl (and yahoo-jp-use-ssl? 114 (make-http-ssl (SSLv3-client-method) 443))) 115 (ret (and appid 116 (http:get yahoo-jp-server (make-query appid) 80 proxy ssl)))) 117 (if (string? ret) 118 (parse ret) 119 (cons '() (list (list str)))))) 120 121(define (yahoo-jp-predict-memoize! yc str cand) 122 (let ((cache (yahoo-jp-context-prediction-cache yc))) 123 (yahoo-jp-context-set-prediction-cache! 124 yc 125 (append (if (<= yahoo-jp-prediction-cache-words 126 (length cache)) 127 (cdr cache) 128 cache) 129 (list (cons str cand)))))) 130(define (yahoo-jp-predict yc str opts) 131 (let ((ret (assoc str (yahoo-jp-context-prediction-cache yc)))) 132 (if ret 133 (cdr ret) 134 (let ((cand (yahoo-jp-predict-from-server str opts))) 135 (if (not (null? (car cand))) 136 (yahoo-jp-predict-memoize! yc str cand)) 137 cand)))) 138(define (yahoo-jp-predict-from-server str opts) 139 (cadr (yahoo-jp-conversion str (string-append "&mode=predictive" opts)))) 140 141(define (yahoo-jp-conversion-make-resize-query yomi-seg) 142 (let ((len (length yomi-seg))) 143 (apply string-append (map (lambda (idx) 144 (if (= (+ idx 1) len) 145 (list-ref yomi-seg idx) 146 (string-append (list-ref yomi-seg idx) " "))) 147 (iota len))))) 148(define (yahoo-jp-conversion-resize yomi-seg) 149 (yahoo-jp-conversion 150 (yahoo-jp-conversion-make-resize-query yomi-seg) "")) 151 152(define (yahoo-jp-lib-init) 153 #t) 154(define (yahoo-jp-lib-alloc-context) 155 (yahoo-jp-internal-context-new-internal)) 156(define (yahoo-jp-lib-get-nth-candidate yc seg nth) 157 (let* ((yx-ctx (yahoo-jp-context-yx-ctx yc)) 158 (cand (yahoo-jp-internal-context-candidates yx-ctx))) 159 (list-ref (list-ref cand seg) nth))) 160(define (yahoo-jp-lib-release-context yc) 161 #t) 162(define (yahoo-jp-lib-get-unconv-candidate yc seg-idx) 163 (let* ((yx-ctx (yahoo-jp-context-yx-ctx yc)) 164 (cand (yahoo-jp-internal-context-candidates yx-ctx))) 165 ;; XXX 166 (car (take-right (list-ref cand seg-idx) 1)))) 167(define (yahoo-jp-lib-get-nr-segments yc) 168 (let* ((yx-ctx (yahoo-jp-context-yx-ctx yc)) 169 (cand (yahoo-jp-internal-context-candidates yx-ctx))) 170 (length cand))) 171(define (yahoo-jp-lib-get-nr-candidates yc seg) 172 (let* ((yx-ctx (yahoo-jp-context-yx-ctx yc)) 173 (cand (yahoo-jp-internal-context-candidates yx-ctx))) 174 (length (list-ref cand seg)))) 175(define (yahoo-jp-next-yomi-seg yomi-seg seg cnt) 176 (let* ((kana-str (list-ref yomi-seg seg)) 177 (kana-list (reverse (string-to-list kana-str)))) 178 (cond ((and (< cnt 0) ;; shrink segment 179 (< 1 (length kana-list))) 180 (let* ((not-edited-head (if (< 0 seg) 181 (take yomi-seg seg) 182 '())) 183 (edited-head (list (apply string-append (drop-right kana-list (* -1 cnt))))) 184 (edited-tail (if (= (+ 1 seg) (length yomi-seg)) ;; end of segments 185 (take-right kana-list (* -1 cnt)) 186 (let* ((next-char (car (take-right kana-list (* -1 cnt)))) 187 (kana-next-str (list-ref yomi-seg (+ 1 seg)))) 188 (list (string-append next-char kana-next-str))))) 189 (not-edited-tail (if (= (+ 1 seg) (length yomi-seg)) 190 '() 191 (drop yomi-seg (+ seg 2))))) 192 (append not-edited-head edited-head edited-tail not-edited-tail))) 193 ((and (< 0 cnt) ;; stretch segment 194 (< (+ seg 1) (length yomi-seg)) 195 (< 0 (length (string-to-list (list-ref yomi-seg (+ seg 1)))))) 196 (let* ((next-str (list-ref yomi-seg (+ seg 1))) 197 (next-kana-list (reverse (string-to-list next-str))) 198 (not-edited-head (if (< 0 seg) 199 (take yomi-seg seg) 200 '())) 201 (edited-head (list (apply string-append 202 (append kana-list 203 (take next-kana-list cnt))))) 204 (edited-tail (if (= 1 (length next-kana-list)) 205 '() 206 (list (apply string-append (drop next-kana-list cnt))))) 207 (not-edited-tail (if (< (length yomi-seg) 2) 208 '() 209 (drop yomi-seg (+ 2 seg))))) 210 (append not-edited-head edited-head edited-tail not-edited-tail))) 211 (else 212 yomi-seg)))) 213(define (yahoo-jp-lib-resize-segment yc seg cnt) 214 (let* ((yx-ctx (yahoo-jp-context-yx-ctx yc)) 215 (cand (yahoo-jp-internal-context-candidates yx-ctx)) 216 (yomi-seg (yahoo-jp-internal-context-yomi-seg yx-ctx)) 217 (next-yomi-seg (yahoo-jp-next-yomi-seg yomi-seg seg cnt)) 218 (replace-yomi-seg-and-next-cand (yahoo-jp-conversion-resize next-yomi-seg)) 219 (replace-yomi-seg (car replace-yomi-seg-and-next-cand)) 220 (next-cand (cdr replace-yomi-seg-and-next-cand))) 221 (if (and next-cand 222 (not (equal? next-cand cand))) 223 (begin 224 (yahoo-jp-internal-context-set-candidates! yx-ctx next-cand) 225 (yahoo-jp-internal-context-set-yomi-seg! yx-ctx replace-yomi-seg))) 226 #t)) 227(define (yahoo-jp-lib-begin-conversion yc str) 228 (let* ((yomi-seg-and-cand (yahoo-jp-conversion str "")) 229 (yomi-seg (car yomi-seg-and-cand)) 230 (cand (cdr yomi-seg-and-cand)) 231 (yx-ctx (yahoo-jp-context-yx-ctx yc))) 232 (yahoo-jp-internal-context-set-yomi-seg! yx-ctx yomi-seg) 233 (yahoo-jp-internal-context-set-candidates! yx-ctx cand) 234 (length cand))) 235(define (yahoo-jp-lib-commit-segments yc delta) 236 #t) 237(define (yahoo-jp-lib-reset-conversion yc) 238 #f) 239(define (yahoo-jp-lib-set-prediction-src-string yc str) 240 (cond ((eq? yahoo-jp-prediction-type 'www) 241 (let ((yx-ctx (yahoo-jp-context-yx-ctx yc)) 242 (cands (yahoo-jp-predict yc str ""))) 243 (yahoo-jp-internal-context-set-prediction-candidates! yx-ctx cands) 244 (yahoo-jp-internal-context-set-prediction-nr! yx-ctx (length cands)))) 245 ((eq? yahoo-jp-prediction-type 'uim) 246 (let* ((ret (predict-meta-search 247 (yahoo-jp-context-prediction-ctx yc) 248 str)) 249 (yx-ctx (yahoo-jp-context-yx-ctx yc)) 250 (word (predict-meta-word? ret)) 251 (cands (predict-meta-candidates? ret)) 252 (appendix (predict-meta-appendix? ret))) 253 (yahoo-jp-internal-context-set-prediction-word! yx-ctx word) 254 (yahoo-jp-internal-context-set-prediction-candidates! yx-ctx cands) 255 (yahoo-jp-internal-context-set-prediction-appendix! yx-ctx appendix) 256 (yahoo-jp-internal-context-set-prediction-nr! yx-ctx (length cands))))) 257 #f) 258(define (yahoo-jp-lib-get-nr-predictions yc) 259 (let ((yx-ctx (yahoo-jp-context-yx-ctx yc))) 260 (yahoo-jp-internal-context-prediction-nr yx-ctx))) 261(define (yahoo-jp-lib-get-nth-word yc nth) 262 (let* ((yx-ctx (yahoo-jp-context-yx-ctx yc)) 263 (word (yahoo-jp-internal-context-prediction-word yx-ctx))) 264 (list-ref word nth))) 265(define (yahoo-jp-lib-get-nth-prediction yc nth) 266 (let* ((yx-ctx (yahoo-jp-context-yx-ctx yc)) 267 (cands (yahoo-jp-internal-context-prediction-candidates yx-ctx))) 268 (list-ref cands nth))) 269(define (yahoo-jp-lib-get-nth-appendix yc nth) 270 (let* ((yx-ctx (yahoo-jp-context-yx-ctx yc)) 271 (appendix (yahoo-jp-internal-context-prediction-appendix yx-ctx))) 272 (list-ref appendix nth))) 273(define (yahoo-jp-lib-commit-nth-prediction yc nth) 274 (if (eq? yahoo-jp-prediction-type 'uim) 275 (let ((yx-ctx (yahoo-jp-context-yx-ctx yc))) 276 (predict-meta-commit 277 (yahoo-jp-context-prediction-ctx yc) 278 (yahoo-jp-lib-get-nth-word yc nth) 279 (yahoo-jp-lib-get-nth-prediction yc nth) 280 (yahoo-jp-lib-get-nth-appendix yc nth)))) 281 #f) 282 283(define yahoo-jp-init-lib-ok? #f) 284 285(define yahoo-jp-type-direct ja-type-direct) 286(define yahoo-jp-type-hiragana ja-type-hiragana) 287(define yahoo-jp-type-katakana ja-type-katakana) 288(define yahoo-jp-type-halfkana ja-type-halfkana) 289(define yahoo-jp-type-halfwidth-alnum ja-type-halfwidth-alnum) 290(define yahoo-jp-type-fullwidth-alnum ja-type-fullwidth-alnum) 291 292(define yahoo-jp-input-rule-roma 0) 293(define yahoo-jp-input-rule-kana 1) 294(define yahoo-jp-input-rule-azik 2) 295(define yahoo-jp-input-rule-act 3) 296(define yahoo-jp-input-rule-kzik 4) 297 298(define yahoo-jp-candidate-type-katakana -2) 299(define yahoo-jp-candidate-type-hiragana -3) 300(define yahoo-jp-candidate-type-halfkana -4) 301(define yahoo-jp-candidate-type-halfwidth-alnum -5) 302(define yahoo-jp-candidate-type-fullwidth-alnum -6) 303(define yahoo-jp-candidate-type-upper-halfwidth-alnum -7) 304(define yahoo-jp-candidate-type-upper-fullwidth-alnum -8) 305 306 307;; I don't think the key needs to be customizable. 308(define-key yahoo-jp-space-key? '(" ")) 309 310(define yahoo-jp-prepare-input-rule-activation 311 (lambda (yc) 312 (cond 313 ((yahoo-jp-context-state yc) 314 (yahoo-jp-do-commit yc)) 315 ((yahoo-jp-context-transposing yc) 316 (im-commit yc (yahoo-jp-transposing-text yc))) 317 ((and 318 (yahoo-jp-context-on yc) 319 (yahoo-jp-has-preedit? yc)) 320 (im-commit 321 yc (yahoo-jp-make-whole-string yc #t (yahoo-jp-context-kana-mode yc))))) 322 (yahoo-jp-flush yc) 323 (yahoo-jp-update-preedit yc))) 324 325(define yahoo-jp-prepare-input-mode-activation 326 (lambda (yc new-mode) 327 (let ((old-kana (yahoo-jp-context-kana-mode yc))) 328 (cond 329 ((yahoo-jp-context-state yc) 330 (yahoo-jp-do-commit yc)) 331 ((yahoo-jp-context-transposing yc) 332 (im-commit yc (yahoo-jp-transposing-text yc)) 333 (yahoo-jp-flush yc)) 334 ((and 335 (yahoo-jp-context-on yc) 336 (yahoo-jp-has-preedit? yc) 337 (not (= old-kana new-mode))) 338 (im-commit 339 yc (yahoo-jp-make-whole-string yc #t (yahoo-jp-context-kana-mode yc))) 340 (yahoo-jp-flush yc))) 341 (yahoo-jp-update-preedit yc)))) 342 343(register-action 'action_yahoo-jp_hiragana 344 (lambda (yc) ;; indication handler 345 '(ja_hiragana 346 "��" 347 "�Ҥ餬��" 348 "�Ҥ餬�����ϥ⡼��")) 349 350 (lambda (yc) ;; activity predicate 351 (and (yahoo-jp-context-on yc) 352 (not (yahoo-jp-context-alnum yc)) 353 (= (yahoo-jp-context-kana-mode yc) 354 yahoo-jp-type-hiragana))) 355 356 (lambda (yc) ;; action handler 357 (yahoo-jp-prepare-input-mode-activation yc yahoo-jp-type-hiragana) 358 (yahoo-jp-context-set-on! yc #t) 359 (yahoo-jp-context-set-alnum! yc #f) 360 (yahoo-jp-context-change-kana-mode! yc yahoo-jp-type-hiragana))) 361 362(register-action 'action_yahoo-jp_katakana 363 (lambda (yc) 364 '(ja_katakana 365 "��" 366 "��������" 367 "�����������ϥ⡼��")) 368 (lambda (yc) 369 (and (yahoo-jp-context-on yc) 370 (not (yahoo-jp-context-alnum yc)) 371 (= (yahoo-jp-context-kana-mode yc) 372 yahoo-jp-type-katakana))) 373 (lambda (yc) 374 (yahoo-jp-prepare-input-mode-activation yc yahoo-jp-type-katakana) 375 (yahoo-jp-context-set-on! yc #t) 376 (yahoo-jp-context-set-alnum! yc #f) 377 (yahoo-jp-context-change-kana-mode! yc yahoo-jp-type-katakana))) 378 379(register-action 'action_yahoo-jp_halfkana 380 (lambda (yc) 381 '(ja_halfkana 382 "��" 383 "Ⱦ�ѥ�������" 384 "Ⱦ�ѥ����������ϥ⡼��")) 385 (lambda (yc) 386 (and (yahoo-jp-context-on yc) 387 (not (yahoo-jp-context-alnum yc)) 388 (= (yahoo-jp-context-kana-mode yc) yahoo-jp-type-halfkana))) 389 (lambda (yc) 390 (yahoo-jp-prepare-input-mode-activation yc yahoo-jp-type-halfkana) 391 (yahoo-jp-context-set-on! yc #t) 392 (yahoo-jp-context-set-alnum! yc #f) 393 (yahoo-jp-context-change-kana-mode! yc yahoo-jp-type-halfkana))) 394 395(register-action 'action_yahoo-jp_halfwidth_alnum 396 (lambda (yc) ;; indication handler 397 '(ja_halfwidth_alnum 398 "a" 399 "Ⱦ�ѱѿ�" 400 "Ⱦ�ѱѿ����ϥ⡼��")) 401 (lambda (yc) ;; activity predicate 402 (and (yahoo-jp-context-on yc) 403 (yahoo-jp-context-alnum yc) 404 (= (yahoo-jp-context-alnum-type yc) 405 yahoo-jp-type-halfwidth-alnum))) 406 (lambda (yc) ;; action handler 407 (yahoo-jp-prepare-input-mode-activation 408 yc (yahoo-jp-context-kana-mode yc)) 409 (yahoo-jp-context-set-on! yc #t) 410 (yahoo-jp-context-set-alnum! yc #t) 411 (yahoo-jp-context-set-alnum-type! 412 yc yahoo-jp-type-halfwidth-alnum))) 413 414(register-action 'action_yahoo-jp_direct 415 (lambda (yc) 416 '(ja_direct 417 "-" 418 "ľ������" 419 "ľ��(̵�Ѵ�)���ϥ⡼��")) 420 (lambda (yc) 421 (not (yahoo-jp-context-on yc))) 422 (lambda (yc) 423 (yahoo-jp-prepare-input-mode-activation yc yahoo-jp-type-direct) 424 (yahoo-jp-context-set-on! yc #f))) 425 426(register-action 'action_yahoo-jp_fullwidth_alnum 427 (lambda (yc) 428 '(ja_fullwidth_alnum 429 "��" 430 "���ѱѿ�" 431 "���ѱѿ����ϥ⡼��")) 432 (lambda (yc) 433 (and (yahoo-jp-context-on yc) 434 (yahoo-jp-context-alnum yc) 435 (= (yahoo-jp-context-alnum-type yc) 436 yahoo-jp-type-fullwidth-alnum))) 437 (lambda (yc) 438 (yahoo-jp-prepare-input-mode-activation 439 yc (yahoo-jp-context-kana-mode yc)) 440 (yahoo-jp-context-set-on! yc #t) 441 (yahoo-jp-context-set-alnum! yc #t) 442 (yahoo-jp-context-set-alnum-type! 443 yc yahoo-jp-type-fullwidth-alnum))) 444 445(register-action 'action_yahoo-jp_roma 446 (lambda (yc) 447 '(ja_romaji 448 "��" 449 "����" 450 "�������ϥ⡼��")) 451 (lambda (yc) 452 (= (yahoo-jp-context-input-rule yc) 453 yahoo-jp-input-rule-roma)) 454 (lambda (yc) 455 (yahoo-jp-prepare-input-rule-activation yc) 456 (rk-context-set-rule! (yahoo-jp-context-rkc yc) 457 ja-rk-rule) 458 (yahoo-jp-context-set-input-rule! yc yahoo-jp-input-rule-roma))) 459 460(register-action 'action_yahoo-jp_kana 461 (lambda (yc) 462 '(ja_kana 463 "��" 464 "����" 465 "�������ϥ⡼��")) 466 (lambda (yc) 467 (= (yahoo-jp-context-input-rule yc) 468 yahoo-jp-input-rule-kana)) 469 (lambda (yc) 470 (yahoo-jp-prepare-input-rule-activation yc) 471 (require "japanese-kana.scm") 472 (yahoo-jp-context-set-input-rule! yc yahoo-jp-input-rule-kana) 473 (yahoo-jp-context-change-kana-mode! 474 yc (yahoo-jp-context-kana-mode yc)) 475 (yahoo-jp-context-set-alnum! yc #f))) 476 477(register-action 'action_yahoo-jp_azik 478 (lambda (yc) 479 '(ja_azik 480 "��" 481 "AZIK" 482 "AZIK��ĥ�������ϥ⡼��")) 483 (lambda (yc) 484 (= (yahoo-jp-context-input-rule yc) 485 yahoo-jp-input-rule-azik)) 486 (lambda (yc) 487 (yahoo-jp-prepare-input-rule-activation yc) 488 (require "japanese-azik.scm") 489 (rk-context-set-rule! (yahoo-jp-context-rkc yc) 490 ja-azik-rule) 491 (yahoo-jp-context-set-input-rule! yc yahoo-jp-input-rule-azik))) 492 493(register-action 'action_yahoo-jp_kzik 494 (lambda (yc) 495 '(ja_kzik 496 "��" 497 "KZIK" 498 "KZIK��ĥ�������ϥ⡼��")) 499 (lambda (yc) 500 (= (yahoo-jp-context-input-rule yc) 501 yahoo-jp-input-rule-kzik)) 502 (lambda (yc) 503 (yahoo-jp-prepare-input-rule-activation yc) 504 (require "japanese-kzik.scm") 505 (rk-context-set-rule! (yahoo-jp-context-rkc yc) 506 ja-kzik-rule) 507 (yahoo-jp-context-set-input-rule! yc yahoo-jp-input-rule-kzik))) 508 509(register-action 'action_yahoo-jp_act 510 (lambda (yc) 511 '(ja_act 512 "��" 513 "ACT" 514 "ACT��ĥ�������ϥ⡼��")) 515 (lambda (yc) 516 (= (yahoo-jp-context-input-rule yc) 517 yahoo-jp-input-rule-act)) 518 (lambda (yc) 519 (yahoo-jp-prepare-input-rule-activation yc) 520 (require "japanese-act.scm") 521 (rk-context-set-rule! (yahoo-jp-context-rkc yc) 522 ja-act-rule) 523 (yahoo-jp-context-set-input-rule! yc yahoo-jp-input-rule-act))) 524 525;; Update widget definitions based on action configurations. The 526;; procedure is needed for on-the-fly reconfiguration involving the 527;; custom API 528(define yahoo-jp-configure-widgets 529 (lambda () 530 (register-widget 'widget_yahoo-jp_input_mode 531 (activity-indicator-new yahoo-jp-input-mode-actions) 532 (actions-new yahoo-jp-input-mode-actions)) 533 534 (register-widget 'widget_yahoo-jp_kana_input_method 535 (activity-indicator-new yahoo-jp-kana-input-method-actions) 536 (actions-new yahoo-jp-kana-input-method-actions)) 537 (context-list-replace-widgets! 'yahoo-jp yahoo-jp-widgets))) 538 539(define yahoo-jp-context-rec-spec 540 (append 541 context-rec-spec 542 (list 543 (list 'on #f) 544 (list 'state #f) 545 (list 'transposing #f) 546 (list 'transposing-type 0) 547 (list 'predicting #f) 548 (list 'yx-ctx ()) ;; yahoo-jp-internal-context 549 (list 'preconv-ustr #f) ;; preedit strings 550 (list 'rkc ()) 551 (list 'segments #f) ;; ustr of candidate indices 552 (list 'candidate-window #f) 553 (list 'candidate-op-count 0) 554 (list 'prediction-ctx '()) 555 (list 'prediction-window #f) 556 (list 'prediction-index #f) 557 (list 'prediction-cache '()) 558 (list 'kana-mode yahoo-jp-type-hiragana) 559 (list 'alnum #f) 560 (list 'alnum-type yahoo-jp-type-halfwidth-alnum) 561 (list 'commit-raw #t) 562 (list 'input-rule yahoo-jp-input-rule-roma) 563 (list 'raw-ustr #f)))) 564(define-record 'yahoo-jp-context yahoo-jp-context-rec-spec) 565(define yahoo-jp-context-new-internal yahoo-jp-context-new) 566 567(define (yahoo-jp-context-new id im) 568 (let ((yc (yahoo-jp-context-new-internal id im)) 569 (rkc (rk-context-new ja-rk-rule #t #f))) 570; (yahoo-jp-context-set-yx-ctx! yc (if yahoo-jp-init-lib-ok? 571; (yahoo-jp-lib-alloc-context) ())) 572 (yahoo-jp-context-set-yx-ctx! yc (yahoo-jp-lib-alloc-context)) 573 (yahoo-jp-context-set-widgets! yc yahoo-jp-widgets) 574 (yahoo-jp-context-set-rkc! yc rkc) 575 (yahoo-jp-context-set-preconv-ustr! yc (ustr-new '())) 576 (yahoo-jp-context-set-raw-ustr! yc (ustr-new '())) 577 (yahoo-jp-context-set-segments! yc (ustr-new '())) 578 (if (and yahoo-jp-use-prediction? 579 (eq? yahoo-jp-prediction-type 'uim)) 580 (begin 581 (yahoo-jp-context-set-prediction-ctx! yc (predict-make-meta-search)) 582 (predict-meta-open (yahoo-jp-context-prediction-ctx yc) "yahoo-jp") 583 (predict-meta-set-external-charset! (yahoo-jp-context-prediction-ctx yc) "EUC-JP"))) 584 yc)) 585 586(define (yahoo-jp-commit-raw yc) 587 (im-commit-raw yc) 588 (yahoo-jp-context-set-commit-raw! yc #t)) 589 590(define (yahoo-jp-context-kana-toggle yc) 591 (let* ((kana (yahoo-jp-context-kana-mode yc)) 592 (opposite-kana (ja-opposite-kana kana))) 593 (yahoo-jp-context-change-kana-mode! yc opposite-kana))) 594 595(define yahoo-jp-context-alkana-toggle 596 (lambda (yc) 597 (let ((alnum-state (yahoo-jp-context-alnum yc))) 598 (yahoo-jp-context-set-alnum! yc (not alnum-state))))) 599 600(define yahoo-jp-context-change-kana-mode! 601 (lambda (yc kana-mode) 602 (if (= (yahoo-jp-context-input-rule yc) 603 yahoo-jp-input-rule-kana) 604 (rk-context-set-rule! 605 (yahoo-jp-context-rkc yc) 606 (cond 607 ((= kana-mode yahoo-jp-type-hiragana) ja-kana-hiragana-rule) 608 ((= kana-mode yahoo-jp-type-katakana) ja-kana-katakana-rule) 609 ((= kana-mode yahoo-jp-type-halfkana) ja-kana-halfkana-rule)))) 610 (yahoo-jp-context-set-kana-mode! yc kana-mode))) 611 612(define yahoo-jp-make-whole-string 613 (lambda (yc convert-pending-into-kana? kana) 614 (let* ((rkc (yahoo-jp-context-rkc yc)) 615 (pending (rk-pending rkc)) 616 (residual-kana (rk-peek-terminal-match rkc)) 617 (rule (yahoo-jp-context-input-rule yc)) 618 (preconv-str (yahoo-jp-context-preconv-ustr yc)) 619 (extract-kana 620 (if (= rule yahoo-jp-input-rule-kana) 621 (lambda (entry) (car entry)) 622 (lambda (entry) (list-ref entry kana))))) 623 624 (if (= rule yahoo-jp-input-rule-kana) 625 (ja-make-kana-str 626 (ja-make-kana-str-list 627 (string-to-list 628 (string-append 629 (string-append-map-ustr-former extract-kana preconv-str) 630 (if convert-pending-into-kana? 631 (if residual-kana 632 (if (list? (car residual-kana)) 633 (string-append-map extract-kana residual-kana) 634 (extract-kana residual-kana)) 635 pending) 636 pending) 637 (string-append-map-ustr-latter extract-kana preconv-str)))) 638 kana) 639 (string-append 640 (string-append-map-ustr-former extract-kana preconv-str) 641 (if convert-pending-into-kana? 642 (if residual-kana 643 (if (list? (car residual-kana)) 644 (string-append-map extract-kana residual-kana) 645 (extract-kana residual-kana)) 646 "") 647 pending) 648 (string-append-map-ustr-latter extract-kana preconv-str)))))) 649 650(define yahoo-jp-make-raw-string 651 (lambda (raw-str-list wide? upper?) 652 (if (not (null? raw-str-list)) 653 (if wide? 654 (string-append 655 (ja-string-list-to-wide-alphabet 656 (if upper? 657 (map charcode->string 658 (map ichar-upcase 659 (map string->charcode 660 (string-to-list (car raw-str-list))))) 661 (string-to-list (car raw-str-list)))) 662 (yahoo-jp-make-raw-string (cdr raw-str-list) wide? upper?)) 663 (string-append 664 (if upper? 665 (string-list-concat 666 (map charcode->string 667 (map ichar-upcase 668 (map string->charcode 669 (string-to-list (car raw-str-list)))))) 670 (car raw-str-list)) 671 (yahoo-jp-make-raw-string (cdr raw-str-list) wide? upper?))) 672 ""))) 673 674(define yahoo-jp-make-whole-raw-string 675 (lambda (yc wide? upper?) 676 (yahoo-jp-make-raw-string (yahoo-jp-get-raw-str-seq yc) wide? upper?))) 677 678(define (yahoo-jp-init-handler id im arg) 679 (if (not yahoo-jp-init-lib-ok?) 680 (begin 681 (yahoo-jp-lib-init) 682 (set! yahoo-jp-init-lib-ok? #t))) 683 (yahoo-jp-context-new id im)) 684 685(define (yahoo-jp-release-handler yc) 686 (if yc 687 (yahoo-jp-lib-release-context yc))) 688 689(define (yahoo-jp-flush yc) 690 (rk-flush (yahoo-jp-context-rkc yc)) 691 (ustr-clear! (yahoo-jp-context-preconv-ustr yc)) 692 (ustr-clear! (yahoo-jp-context-raw-ustr yc)) 693 (ustr-clear! (yahoo-jp-context-segments yc)) 694 (yahoo-jp-context-set-transposing! yc #f) 695 (yahoo-jp-context-set-state! yc #f) 696 (if (or 697 (yahoo-jp-context-candidate-window yc) 698 (yahoo-jp-context-prediction-window yc)) 699 (im-deactivate-candidate-selector yc)) 700 (yahoo-jp-context-set-candidate-window! yc #f) 701 (yahoo-jp-context-set-prediction-window! yc #f) 702 (yahoo-jp-context-set-candidate-op-count! yc 0)) 703 704(define (yahoo-jp-begin-input yc key key-state) 705 (if (cond 706 ((yahoo-jp-on-key? key key-state) 707 #t) 708 ((and 709 yahoo-jp-use-mode-transition-keys-in-off-mode? 710 (cond 711 ((yahoo-jp-hiragana-key? key key-state) 712 (yahoo-jp-context-set-kana-mode! yc yahoo-jp-type-hiragana) 713 (yahoo-jp-context-set-alnum! yc #f) 714 #t) 715 ((yahoo-jp-katakana-key? key key-state) 716 (yahoo-jp-context-set-kana-mode! yc yahoo-jp-type-katakana) 717 (yahoo-jp-context-set-alnum! yc #f) 718 #t) 719 ((yahoo-jp-halfkana-key? key key-state) 720 (yahoo-jp-context-set-kana-mode! yc yahoo-jp-type-halfkana) 721 (yahoo-jp-context-set-alnum! yc #f) 722 #t) 723 ((yahoo-jp-halfwidth-alnum-key? key key-state) 724 (yahoo-jp-context-set-alnum-type! yc yahoo-jp-type-halfwidth-alnum) 725 (yahoo-jp-context-set-alnum! yc #t) 726 #t) 727 ((yahoo-jp-halfwidth-alnum-key? key key-state) 728 (yahoo-jp-context-set-alnum-type! yc yahoo-jp-type-fullwidth-alnum) 729 (yahoo-jp-context-set-alnum! yc #t) 730 #t) 731 ((yahoo-jp-kana-toggle-key? key key-state) 732 (yahoo-jp-context-kana-toggle yc) 733 (yahoo-jp-context-set-alnum! yc #f) 734 #t) 735 ((yahoo-jp-alkana-toggle-key? key key-state) 736 (yahoo-jp-context-alkana-toggle yc) 737 #t) 738 (else 739 #f)))) 740 (else 741 #f)) 742 (begin 743 (yahoo-jp-context-set-on! yc #t) 744 (rk-flush (yahoo-jp-context-rkc yc)) 745 (yahoo-jp-context-set-state! yc #f) 746 #t) 747 #f)) 748 749(define (yahoo-jp-update-preedit yc) 750 (if (not (yahoo-jp-context-commit-raw yc)) 751 (let ((segments (if (yahoo-jp-context-on yc) 752 (if (yahoo-jp-context-transposing yc) 753 (yahoo-jp-context-transposing-state-preedit yc) 754 (if (yahoo-jp-context-state yc) 755 (yahoo-jp-compose-state-preedit yc) 756 (if (yahoo-jp-context-predicting yc) 757 (yahoo-jp-predicting-state-preedit yc) 758 (yahoo-jp-input-state-preedit yc)))) 759 ()))) 760 (context-update-preedit yc segments)) 761 (yahoo-jp-context-set-commit-raw! yc #f))) 762 763(define (yahoo-jp-begin-conv yc) 764 (let ((yx-ctx (yahoo-jp-context-yx-ctx yc)) 765 (preconv-str (yahoo-jp-make-whole-string yc #t yahoo-jp-type-hiragana))) 766 (if (and yx-ctx 767 (> (string-length preconv-str) 0)) 768 (let ((num (yahoo-jp-lib-begin-conversion yc preconv-str))) 769 (if num 770 (begin 771 (ustr-set-latter-seq! 772 (yahoo-jp-context-segments yc) 773 (make-list num 0)) 774 (yahoo-jp-context-set-state! yc #t) 775 ;; Don't perform rk-flush here. The rkc must be restored when 776 ;; yahoo-jp-cancel-conv invoked -- YamaKen 2004-10-25 777 )))))) 778 779(define yahoo-jp-cancel-conv 780 (lambda (yc) 781 (yahoo-jp-reset-candidate-window yc) 782 (yahoo-jp-context-set-state! yc #f) 783 (ustr-clear! (yahoo-jp-context-segments yc)) 784 (yahoo-jp-lib-reset-conversion yc))) 785 786(define (yahoo-jp-proc-input-state-no-preedit yc key key-state) 787 (let 788 ((rkc (yahoo-jp-context-rkc yc)) 789 (direct (ja-direct (charcode->string key))) 790 (rule (yahoo-jp-context-input-rule yc))) 791 (cond 792 ((and yahoo-jp-use-with-vi? 793 (yahoo-jp-vi-escape-key? key key-state)) 794 (yahoo-jp-flush yc) 795 (yahoo-jp-context-set-on! yc #f) 796 (yahoo-jp-commit-raw yc)) 797 798 ((yahoo-jp-off-key? key key-state) 799 (yahoo-jp-flush yc) 800 (yahoo-jp-context-set-on! yc #f)) 801 802 ((yahoo-jp-backspace-key? key key-state) 803 (yahoo-jp-commit-raw yc)) 804 805 ((yahoo-jp-delete-key? key key-state) 806 (yahoo-jp-commit-raw yc)) 807 808 ((and 809 (yahoo-jp-hiragana-key? key key-state) 810 (not 811 (and 812 (= (yahoo-jp-context-kana-mode yc) yahoo-jp-type-hiragana) 813 (not (yahoo-jp-context-alnum yc))))) 814 (yahoo-jp-context-change-kana-mode! yc yahoo-jp-type-hiragana) 815 (yahoo-jp-context-set-alnum! yc #f)) 816 817 ((and 818 (yahoo-jp-katakana-key? key key-state) 819 (not 820 (and 821 (= (yahoo-jp-context-kana-mode yc) yahoo-jp-type-katakana) 822 (not (yahoo-jp-context-alnum yc))))) 823 (yahoo-jp-context-change-kana-mode! yc yahoo-jp-type-katakana) 824 (yahoo-jp-context-set-alnum! yc #f)) 825 826 ((and 827 (yahoo-jp-halfkana-key? key key-state) 828 (not 829 (and 830 (= (yahoo-jp-context-kana-mode yc) yahoo-jp-type-halfkana) 831 (not (yahoo-jp-context-alnum yc))))) 832 (yahoo-jp-context-change-kana-mode! yc yahoo-jp-type-halfkana) 833 (yahoo-jp-context-set-alnum! yc #f)) 834 835 ((and 836 (yahoo-jp-halfwidth-alnum-key? key key-state) 837 (not 838 (and 839 (= (yahoo-jp-context-alnum-type yc) yahoo-jp-type-halfwidth-alnum) 840 (yahoo-jp-context-alnum yc)))) 841 (yahoo-jp-context-set-alnum-type! yc yahoo-jp-type-halfwidth-alnum) 842 (yahoo-jp-context-set-alnum! yc #t)) 843 844 ((and 845 (yahoo-jp-fullwidth-alnum-key? key key-state) 846 (not 847 (and 848 (= (yahoo-jp-context-alnum-type yc) yahoo-jp-type-fullwidth-alnum) 849 (yahoo-jp-context-alnum yc)))) 850 (yahoo-jp-context-set-alnum-type! yc yahoo-jp-type-fullwidth-alnum) 851 (yahoo-jp-context-set-alnum! yc #t)) 852 853 ((and 854 (not (yahoo-jp-context-alnum yc)) 855 (yahoo-jp-kana-toggle-key? key key-state)) 856 (yahoo-jp-context-kana-toggle yc)) 857 858 ((yahoo-jp-alkana-toggle-key? key key-state) 859 (yahoo-jp-context-alkana-toggle yc)) 860 861 ;; modifiers (except shift) => ignore 862 ((and (modifier-key-mask key-state) 863 (not (shift-key-mask key-state))) 864 (yahoo-jp-commit-raw yc)) 865 866 ;; direct key => commit 867 (direct 868 (im-commit yc direct)) 869 870 ;; space key 871 ((yahoo-jp-space-key? key key-state) 872 (if (yahoo-jp-context-alnum yc) 873 (im-commit yc (list-ref 874 ja-alnum-space 875 (- (yahoo-jp-context-alnum-type yc) 876 yahoo-jp-type-halfwidth-alnum))) 877 (im-commit yc (list-ref ja-space (yahoo-jp-context-kana-mode yc))))) 878 879 ((symbol? key) 880 (yahoo-jp-commit-raw yc)) 881 882 (else 883 (if (yahoo-jp-context-alnum yc) 884 (let ((key-str (charcode->string key))) 885 (ustr-insert-elem! (yahoo-jp-context-preconv-ustr yc) 886 (if (= (yahoo-jp-context-alnum-type yc) 887 yahoo-jp-type-halfwidth-alnum) 888 (list key-str key-str key-str) 889 (list (ja-wide key-str) (ja-wide key-str) 890 (ja-wide key-str)))) 891 (ustr-insert-elem! (yahoo-jp-context-raw-ustr yc) key-str)) 892 (let* ((key-str (charcode->string 893 (if (= rule yahoo-jp-input-rule-kana) 894 key 895 (ichar-downcase key)))) 896 (res (rk-push-key! rkc key-str))) 897 (if res 898 (begin 899 (if (list? (car res)) 900 (ustr-insert-seq! (yahoo-jp-context-preconv-ustr yc) res) 901 (ustr-insert-elem! (yahoo-jp-context-preconv-ustr yc) res)) 902 (ustr-insert-elem! (yahoo-jp-context-raw-ustr yc) key-str)) 903 (if (null? (rk-context-seq rkc)) 904 (yahoo-jp-commit-raw yc))))))))) 905 906(define (yahoo-jp-has-preedit? yc) 907 (or (not (ustr-empty? (yahoo-jp-context-preconv-ustr yc))) 908 (> (string-length (rk-pending (yahoo-jp-context-rkc yc))) 0))) 909 910(define yahoo-jp-rotate-transposing-alnum-type 911 (lambda (cur-type state) 912 (cond 913 ((and 914 (= cur-type yahoo-jp-type-halfwidth-alnum) 915 (= state yahoo-jp-type-halfwidth-alnum)) 916 yahoo-jp-candidate-type-upper-halfwidth-alnum) 917 ((and 918 (= cur-type yahoo-jp-type-fullwidth-alnum) 919 (= state yahoo-jp-type-fullwidth-alnum)) 920 yahoo-jp-candidate-type-upper-fullwidth-alnum) 921 (else 922 state)))) 923 924(define yahoo-jp-proc-transposing-state 925 (lambda (yc key key-state) 926 (let ((rotate-list '()) 927 (state #f)) 928 (if (yahoo-jp-transpose-as-fullwidth-alnum-key? key key-state) 929 (set! rotate-list (cons yahoo-jp-type-fullwidth-alnum rotate-list))) 930 (if (yahoo-jp-transpose-as-halfwidth-alnum-key? key key-state) 931 (set! rotate-list (cons yahoo-jp-type-halfwidth-alnum rotate-list))) 932 (if (yahoo-jp-transpose-as-halfkana-key? key key-state) 933 (set! rotate-list (cons yahoo-jp-type-halfkana rotate-list))) 934 (if (yahoo-jp-transpose-as-katakana-key? key key-state) 935 (set! rotate-list (cons yahoo-jp-type-katakana rotate-list))) 936 (if (yahoo-jp-transpose-as-hiragana-key? key key-state) 937 (set! rotate-list (cons yahoo-jp-type-hiragana rotate-list))) 938 939 (if (yahoo-jp-context-transposing yc) 940 (let ((lst (member (yahoo-jp-context-transposing-type yc) rotate-list))) 941 (if (and lst 942 (not (null? (cdr lst)))) 943 (set! state (car (cdr lst))) 944 (if (not (null? rotate-list)) 945 (set! state (yahoo-jp-rotate-transposing-alnum-type 946 (yahoo-jp-context-transposing-type yc) 947 (car rotate-list)))))) 948 (begin 949 (yahoo-jp-context-set-transposing! yc #t) 950 (set! state (car rotate-list)))) 951 952 (cond 953 ((and state 954 (or 955 (= state yahoo-jp-type-hiragana) 956 (= state yahoo-jp-type-katakana) 957 (= state yahoo-jp-type-halfkana))) 958 (yahoo-jp-context-set-transposing-type! yc state)) 959 ((and state 960 (or 961 (= state yahoo-jp-type-halfwidth-alnum) 962 (= state yahoo-jp-candidate-type-upper-halfwidth-alnum) 963 (= state yahoo-jp-type-fullwidth-alnum) 964 (= state yahoo-jp-candidate-type-upper-fullwidth-alnum))) 965 (if (not (= (yahoo-jp-context-input-rule yc) yahoo-jp-input-rule-kana)) 966 (yahoo-jp-context-set-transposing-type! yc state))) 967 (else 968 (and 969 ; commit 970 (if (yahoo-jp-commit-key? key key-state) 971 (begin 972 (im-commit yc (yahoo-jp-transposing-text yc)) 973 (yahoo-jp-flush yc) 974 #f) 975 #t) 976 ; begin-conv 977 (if (yahoo-jp-begin-conv-key? key key-state) 978 (begin 979 (yahoo-jp-context-set-transposing! yc #f) 980 (yahoo-jp-begin-conv yc) 981 #f) 982 #t) 983 ; cancel 984 (if (or 985 (yahoo-jp-cancel-key? key key-state) 986 (yahoo-jp-backspace-key? key key-state)) 987 (begin 988 (yahoo-jp-context-set-transposing! yc #f) 989 #f) 990 #t) 991 ; ignore 992 (if (or 993 (yahoo-jp-prev-page-key? key key-state) 994 (yahoo-jp-next-page-key? key key-state) 995 (yahoo-jp-extend-segment-key? key key-state) 996 (yahoo-jp-shrink-segment-key? key key-state) 997 (yahoo-jp-next-segment-key? key key-state) 998 (yahoo-jp-beginning-of-preedit-key? key key-state) 999 (yahoo-jp-end-of-preedit-key? key key-state) 1000 (yahoo-jp-next-candidate-key? key key-state) 1001 (yahoo-jp-prev-candidate-key? key key-state) 1002 (and 1003 (modifier-key-mask key-state) 1004 (not (shift-key-mask key-state))) 1005 (symbol? key)) 1006 #f 1007 #t) 1008 ; implicit commit 1009 (begin 1010 (im-commit yc (yahoo-jp-transposing-text yc)) 1011 (yahoo-jp-flush yc) 1012 (yahoo-jp-proc-input-state yc key key-state)))))))) 1013 1014(define (yahoo-jp-move-prediction yc offset) 1015 (let* ((nr (yahoo-jp-lib-get-nr-predictions yc)) 1016 (idx (yahoo-jp-context-prediction-index yc)) 1017 (n (if (not idx) 1018 0 1019 (+ idx offset))) 1020 (compensated-n (cond 1021 ((>= n nr) 1022 0) 1023 ((< n 0) 1024 (- nr 1)) 1025 (else 1026 n)))) 1027 (im-select-candidate yc compensated-n) 1028 (yahoo-jp-context-set-prediction-index! yc compensated-n))) 1029 1030(define (yahoo-jp-move-prediction-in-page yc numeralc) 1031 (let* ((nr (yahoo-jp-lib-get-nr-predictions yc)) 1032 (p-idx (yahoo-jp-context-prediction-index yc)) 1033 (n (if (not p-idx) 1034 0 1035 p-idx)) 1036 (cur-page (if (= yahoo-jp-nr-candidate-max 0) 1037 0 1038 (quotient n yahoo-jp-nr-candidate-max))) 1039 (pageidx (- (numeric-ichar->integer numeralc) 1)) 1040 (compensated-pageidx (cond 1041 ((< pageidx 0) ; pressing key_0 1042 (+ pageidx 10)) 1043 (else 1044 pageidx))) 1045 (idx (+ (* cur-page yahoo-jp-nr-candidate-max) compensated-pageidx)) 1046 (compensated-idx (cond 1047 ((>= idx nr) 1048 #f) 1049 (else 1050 idx))) 1051 (selected-pageidx (if (not p-idx) 1052 #f 1053 (if (= yahoo-jp-nr-candidate-max 0) 1054 p-idx 1055 (remainder p-idx 1056 yahoo-jp-nr-candidate-max))))) 1057 (if (and 1058 compensated-idx 1059 (not (eqv? compensated-pageidx selected-pageidx))) 1060 (begin 1061 (yahoo-jp-context-set-prediction-index! yc compensated-idx) 1062 (im-select-candidate yc compensated-idx) 1063 #t) 1064 #f))) 1065 1066(define (yahoo-jp-prediction-select-non-existing-index? yc numeralc) 1067 (let* ((nr (yahoo-jp-lib-get-nr-predictions yc)) 1068 (p-idx (yahoo-jp-context-prediction-index yc)) 1069 (cur-page (if (= yahoo-jp-nr-candidate-max 0) 1070 0 1071 (quotient p-idx yahoo-jp-nr-candidate-max))) 1072 (pageidx (- (numeric-ichar->integer numeralc) 1)) 1073 (compensated-pageidx (cond 1074 ((< pageidx 0) ; pressing key_0 1075 (+ pageidx 10)) 1076 (else 1077 pageidx))) 1078 (idx (+ (* cur-page yahoo-jp-nr-candidate-max) compensated-pageidx))) 1079 (if (>= idx nr) 1080 #t 1081 #f))) 1082 1083(define (yahoo-jp-prediction-keys-handled? yc key key-state) 1084 (cond 1085 ((yahoo-jp-next-prediction-key? key key-state) 1086 (yahoo-jp-move-prediction yc 1) 1087 #t) 1088 ((yahoo-jp-prev-prediction-key? key key-state) 1089 (yahoo-jp-move-prediction yc -1) 1090 #t) 1091 ((and 1092 yahoo-jp-select-prediction-by-numeral-key? 1093 (ichar-numeric? key)) 1094 (yahoo-jp-move-prediction-in-page yc key)) 1095 ((and 1096 (yahoo-jp-context-prediction-index yc) 1097 (yahoo-jp-prev-page-key? key key-state)) 1098 (im-shift-page-candidate yc #f) 1099 #t) 1100 ((and 1101 (yahoo-jp-context-prediction-index yc) 1102 (yahoo-jp-next-page-key? key key-state)) 1103 (im-shift-page-candidate yc #t) 1104 #t) 1105 (else 1106 #f))) 1107 1108(define (yahoo-jp-proc-prediction-state yc key key-state) 1109 (cond 1110 ;; prediction index change 1111 ((yahoo-jp-prediction-keys-handled? yc key key-state)) 1112 1113 ;; cancel 1114 ((yahoo-jp-cancel-key? key key-state) 1115 (if (yahoo-jp-context-prediction-index yc) 1116 (yahoo-jp-reset-prediction-window yc) 1117 (begin 1118 (yahoo-jp-reset-prediction-window yc) 1119 (yahoo-jp-proc-input-state yc key key-state)))) 1120 1121 ;; commit 1122 ((and 1123 (yahoo-jp-context-prediction-index yc) 1124 (yahoo-jp-commit-key? key key-state)) 1125 (yahoo-jp-do-commit-prediction yc)) 1126 (else 1127 (if (and 1128 yahoo-jp-use-implicit-commit-prediction? 1129 (yahoo-jp-context-prediction-index yc)) 1130 (cond 1131 ((or 1132 ;; check keys used in yahoo-jp-proc-input-state-with-preedit 1133 (yahoo-jp-begin-conv-key? key key-state) 1134 (yahoo-jp-backspace-key? key key-state) 1135 (yahoo-jp-delete-key? key key-state) 1136 (yahoo-jp-kill-key? key key-state) 1137 (yahoo-jp-kill-backward-key? key key-state) 1138 (and 1139 (not (yahoo-jp-context-alnum yc)) 1140 (yahoo-jp-commit-as-opposite-kana-key? key key-state)) 1141 (yahoo-jp-transpose-as-hiragana-key? key key-state) 1142 (yahoo-jp-transpose-as-katakana-key? key key-state) 1143 (yahoo-jp-transpose-as-halfkana-key? key key-state) 1144 (and 1145 (not (= (yahoo-jp-context-input-rule yc) yahoo-jp-input-rule-kana)) 1146 (or 1147 (yahoo-jp-transpose-as-halfwidth-alnum-key? key key-state) 1148 (yahoo-jp-transpose-as-fullwidth-alnum-key? key key-state))) 1149 (yahoo-jp-hiragana-key? key key-state) 1150 (yahoo-jp-katakana-key? key key-state) 1151 (yahoo-jp-halfkana-key? key key-state) 1152 (yahoo-jp-halfwidth-alnum-key? key key-state) 1153 (yahoo-jp-fullwidth-alnum-key? key key-state) 1154 (and 1155 (not (yahoo-jp-context-alnum yc)) 1156 (yahoo-jp-kana-toggle-key? key key-state)) 1157 (yahoo-jp-alkana-toggle-key? key key-state) 1158 (yahoo-jp-go-left-key? key key-state) 1159 (yahoo-jp-go-right-key? key key-state) 1160 (yahoo-jp-beginning-of-preedit-key? key key-state) 1161 (yahoo-jp-end-of-preedit-key? key key-state) 1162 (and 1163 (modifier-key-mask key-state) 1164 (not (shift-key-mask key-state)))) 1165 ;; go back to unselected prediction 1166 (yahoo-jp-reset-prediction-window yc) 1167 (yahoo-jp-check-prediction yc #f)) 1168 ((and 1169 (ichar-numeric? key) 1170 yahoo-jp-select-prediction-by-numeral-key? 1171 (not (yahoo-jp-prediction-select-non-existing-index? yc key))) 1172 (yahoo-jp-context-set-predicting! yc #f) 1173 (yahoo-jp-context-set-prediction-index! yc #f) 1174 (yahoo-jp-proc-input-state yc key key-state)) 1175 (else 1176 ;; implicit commit 1177 (yahoo-jp-do-commit-prediction yc) 1178 (yahoo-jp-proc-input-state yc key key-state))) 1179 (begin 1180 (yahoo-jp-context-set-predicting! yc #f) 1181 (yahoo-jp-context-set-prediction-index! yc #f) 1182 (if (not yahoo-jp-use-prediction?) 1183 (yahoo-jp-reset-prediction-window yc)) 1184 (yahoo-jp-proc-input-state yc key key-state)))))) 1185 1186(define (yahoo-jp-proc-input-state-with-preedit yc key key-state) 1187 (define (check-auto-conv str) 1188 (and 1189 str 1190 yahoo-jp-auto-start-henkan? 1191 (string-find japanese-auto-start-henkan-keyword-list str) 1192 (begin 1193 (yahoo-jp-reset-prediction-window yc) 1194 (yahoo-jp-begin-conv yc)))) 1195 (let ((preconv-str (yahoo-jp-context-preconv-ustr yc)) 1196 (raw-str (yahoo-jp-context-raw-ustr yc)) 1197 (rkc (yahoo-jp-context-rkc yc)) 1198 (rule (yahoo-jp-context-input-rule yc)) 1199 (kana (yahoo-jp-context-kana-mode yc))) 1200 (cond 1201 ;; begin conversion 1202 ((yahoo-jp-begin-conv-key? key key-state) 1203 (yahoo-jp-begin-conv yc)) 1204 1205 ;; prediction 1206 ((yahoo-jp-next-prediction-key? key key-state) 1207 (yahoo-jp-check-prediction yc #t)) 1208 1209 ;; backspace 1210 ((yahoo-jp-backspace-key? key key-state) 1211 (if (not (rk-backspace rkc)) 1212 (begin 1213 (ustr-cursor-delete-backside! preconv-str) 1214 (ustr-cursor-delete-backside! raw-str) 1215 ;; fix to valid roma 1216 (if (and 1217 (= (yahoo-jp-context-input-rule yc) yahoo-jp-input-rule-roma) 1218 (not (null? (ustr-former-seq preconv-str))) 1219 (not (ichar-printable? 1220 (string->ichar 1221 (car (last (ustr-former-seq preconv-str))))))) 1222 (ja-fix-deleted-raw-str-to-valid-roma! raw-str))))) 1223 1224 ;; delete 1225 ((yahoo-jp-delete-key? key key-state) 1226 (if (not (rk-delete rkc)) 1227 (begin 1228 (ustr-cursor-delete-frontside! preconv-str) 1229 (ustr-cursor-delete-frontside! raw-str)))) 1230 1231 ;; kill 1232 ((yahoo-jp-kill-key? key key-state) 1233 (ustr-clear-latter! preconv-str) 1234 (ustr-clear-latter! raw-str)) 1235 1236 ;; kill-backward 1237 ((yahoo-jp-kill-backward-key? key key-state) 1238 (rk-flush rkc) 1239 (ustr-clear-former! preconv-str) 1240 (ustr-clear-former! raw-str)) 1241 1242 ;; ���ߤȤϵդΤ��ʥ⡼�ɤǤ��ʤ���ꤹ�� 1243 ((and 1244 (not (yahoo-jp-context-alnum yc)) 1245 (yahoo-jp-commit-as-opposite-kana-key? key key-state)) 1246 (im-commit yc (yahoo-jp-make-whole-string yc #t (ja-opposite-kana kana))) 1247 (yahoo-jp-flush yc)) 1248 1249 ;; Transposing���֤ذܹ� 1250 ((or (yahoo-jp-transpose-as-hiragana-key? key key-state) 1251 (yahoo-jp-transpose-as-katakana-key? key key-state) 1252 (yahoo-jp-transpose-as-halfkana-key? key key-state) 1253 (and 1254 (not (= (yahoo-jp-context-input-rule yc) yahoo-jp-input-rule-kana)) 1255 (or 1256 (yahoo-jp-transpose-as-halfwidth-alnum-key? key key-state) 1257 (yahoo-jp-transpose-as-fullwidth-alnum-key? key key-state)))) 1258 (yahoo-jp-reset-prediction-window yc) 1259 (yahoo-jp-proc-transposing-state yc key key-state)) 1260 1261 ((yahoo-jp-hiragana-key? key key-state) 1262 (if (not (= kana yahoo-jp-type-hiragana)) 1263 (begin 1264 (im-commit yc (yahoo-jp-make-whole-string yc #t kana)) 1265 (yahoo-jp-flush yc))) 1266 (yahoo-jp-context-set-kana-mode! yc yahoo-jp-type-hiragana) 1267 (yahoo-jp-context-set-alnum! yc #f)) 1268 1269 ((yahoo-jp-katakana-key? key key-state) 1270 (if (not (= kana yahoo-jp-type-katakana)) 1271 (begin 1272 (im-commit yc (yahoo-jp-make-whole-string yc #t kana)) 1273 (yahoo-jp-flush yc))) 1274 (yahoo-jp-context-set-kana-mode! yc yahoo-jp-type-katakana) 1275 (yahoo-jp-context-set-alnum! yc #f)) 1276 1277 ((yahoo-jp-halfkana-key? key key-state) 1278 (if (not (= kana yahoo-jp-type-halfkana)) 1279 (begin 1280 (im-commit yc (yahoo-jp-make-whole-string yc #t kana)) 1281 (yahoo-jp-flush yc))) 1282 (yahoo-jp-context-set-kana-mode! yc yahoo-jp-type-halfkana) 1283 (yahoo-jp-context-set-alnum! yc #f)) 1284 1285 ((and 1286 (yahoo-jp-halfwidth-alnum-key? key key-state) 1287 (not 1288 (and 1289 (= (yahoo-jp-context-alnum-type yc) yahoo-jp-type-halfwidth-alnum) 1290 (yahoo-jp-context-alnum yc)))) 1291 (yahoo-jp-context-set-alnum-type! yc yahoo-jp-type-halfwidth-alnum) 1292 (yahoo-jp-context-set-alnum! yc #t)) 1293 1294 ((and 1295 (yahoo-jp-fullwidth-alnum-key? key key-state) 1296 (not 1297 (and 1298 (= (yahoo-jp-context-alnum-type yc) yahoo-jp-type-fullwidth-alnum) 1299 (yahoo-jp-context-alnum yc)))) 1300 (yahoo-jp-context-set-alnum-type! yc yahoo-jp-type-fullwidth-alnum) 1301 (yahoo-jp-context-set-alnum! yc #t)) 1302 1303 ;; Commit current preedit string, then toggle hiragana/katakana mode. 1304 ((and 1305 (not (yahoo-jp-context-alnum yc)) 1306 (yahoo-jp-kana-toggle-key? key key-state)) 1307 (im-commit yc (yahoo-jp-make-whole-string yc #t kana)) 1308 (yahoo-jp-flush yc) 1309 (yahoo-jp-context-kana-toggle yc)) 1310 1311 ((yahoo-jp-alkana-toggle-key? key key-state) 1312 (yahoo-jp-context-alkana-toggle yc)) 1313 1314 ;; cancel 1315 ((yahoo-jp-cancel-key? key key-state) 1316 (yahoo-jp-flush yc)) 1317 1318 ;; commit 1319 ((yahoo-jp-commit-key? key key-state) 1320 (begin 1321 (im-commit 1322 yc 1323 (yahoo-jp-make-whole-string yc #t kana)) 1324 (yahoo-jp-flush yc))) 1325 1326 ;; left 1327 ((yahoo-jp-go-left-key? key key-state) 1328 (yahoo-jp-context-confirm-kana! yc) 1329 (ustr-cursor-move-backward! preconv-str) 1330 (ustr-cursor-move-backward! raw-str)) 1331 1332 ;; right 1333 ((yahoo-jp-go-right-key? key key-state) 1334 (yahoo-jp-context-confirm-kana! yc) 1335 (ustr-cursor-move-forward! preconv-str) 1336 (ustr-cursor-move-forward! raw-str)) 1337 1338 ;; beginning-of-preedit 1339 ((yahoo-jp-beginning-of-preedit-key? key key-state) 1340 (yahoo-jp-context-confirm-kana! yc) 1341 (ustr-cursor-move-beginning! preconv-str) 1342 (ustr-cursor-move-beginning! raw-str)) 1343 1344 ;; end-of-preedit 1345 ((yahoo-jp-end-of-preedit-key? key key-state) 1346 (yahoo-jp-context-confirm-kana! yc) 1347 (ustr-cursor-move-end! preconv-str) 1348 (ustr-cursor-move-end! raw-str)) 1349 1350 ;; modifiers (except shift) => ignore 1351 ((and (modifier-key-mask key-state) 1352 (not (shift-key-mask key-state))) 1353 #f) 1354 1355 ((symbol? key) 1356 #f) 1357 1358 (else 1359 (if (yahoo-jp-context-alnum yc) 1360 (let ((key-str (charcode->string key)) 1361 (pend (rk-pending rkc)) 1362 (residual-kana (rk-peek-terminal-match rkc))) 1363 (rk-flush rkc) ;; OK to reset rkc here. 1364 (if residual-kana 1365 (begin 1366 (if (list? (car residual-kana)) 1367 (begin 1368 (ustr-insert-seq! preconv-str residual-kana) 1369 (ustr-insert-elem! raw-str (reverse 1370 (string-to-list pend)))) 1371 (begin 1372 (ustr-insert-elem! preconv-str residual-kana) 1373 (ustr-insert-elem! raw-str pend))))) 1374 (ustr-insert-elem! preconv-str 1375 (if (= (yahoo-jp-context-alnum-type yc) 1376 yahoo-jp-type-halfwidth-alnum) 1377 (list key-str key-str key-str) 1378 (list (ja-wide key-str) (ja-wide key-str) 1379 (ja-wide key-str)))) 1380 (ustr-insert-elem! raw-str key-str) 1381 (check-auto-conv key-str)) 1382 (let* ((key-str (charcode->string 1383 (if (= rule yahoo-jp-input-rule-kana) 1384 key 1385 (ichar-downcase key)))) 1386 (pend (rk-pending rkc)) 1387 (res (rk-push-key! rkc key-str))) 1388 (if (and res 1389 (or (list? (car res)) 1390 (not (string=? (car res) "")))) 1391 (let ((next-pend (rk-pending rkc))) 1392 (if (list? (car res)) 1393 (ustr-insert-seq! preconv-str res) 1394 (ustr-insert-elem! preconv-str res)) 1395 (if (and next-pend 1396 (not (string=? next-pend ""))) 1397 (ustr-insert-seq! raw-str 1398 (reverse (string-to-list pend))) 1399 (if (list? (car res)) 1400 (begin 1401 (if (member pend 1402 (map car 1403 ja-consonant-syllable-table)) 1404 ;; treat consonant having more than one 1405 ;; charactear as one raw-str in this case 1406 (ustr-insert-elem! raw-str pend) 1407 (ustr-insert-elem! raw-str (reverse 1408 (string-to-list 1409 pend)))) 1410 ;; assume key-str as a vowel 1411 (ustr-insert-elem! raw-str key-str)) 1412 (ustr-insert-elem! 1413 raw-str 1414 (string-append pend key-str)))))) 1415 (check-auto-conv (if res (car res) #f)))))))) 1416 1417(define yahoo-jp-context-confirm-kana! 1418 (lambda (yc) 1419 (if (= (yahoo-jp-context-input-rule yc) 1420 yahoo-jp-input-rule-kana) 1421 (let* ((preconv-str (yahoo-jp-context-preconv-ustr yc)) 1422 (rkc (yahoo-jp-context-rkc yc)) 1423 (residual-kana (rk-peek-terminal-match rkc))) 1424 (if residual-kana 1425 (begin 1426 (if (list? (car residual-kana)) 1427 (ustr-insert-seq! preconv-str residual-kana) 1428 (ustr-insert-elem! preconv-str residual-kana)) 1429 (rk-flush rkc))))))) 1430 1431(define (yahoo-jp-reset-prediction-window yc) 1432 (if (yahoo-jp-context-prediction-window yc) 1433 (im-deactivate-candidate-selector yc)) 1434 (yahoo-jp-context-set-predicting! yc #f) 1435 (yahoo-jp-context-set-prediction-window! yc #f) 1436 (yahoo-jp-context-set-prediction-index! yc #f)) 1437 1438(define (yahoo-jp-check-prediction yc force-check?) 1439 (if (and 1440 (not (yahoo-jp-context-state yc)) 1441 (not (yahoo-jp-context-transposing yc)) 1442 (not (yahoo-jp-context-predicting yc))) 1443 (let* ((use-pending-rk-for-prediction? #t) 1444 (preconv-str 1445 (yahoo-jp-make-whole-string 1446 yc 1447 (not use-pending-rk-for-prediction?) 1448 (yahoo-jp-context-kana-mode yc))) 1449 (preedit-len (+ 1450 (ustr-length (yahoo-jp-context-preconv-ustr yc)) 1451 (if (not use-pending-rk-for-prediction?) 1452 0 1453 (string-length (rk-pending 1454 (yahoo-jp-context-rkc 1455 yc))))))) 1456 (if (or 1457 (>= preedit-len yahoo-jp-prediction-start-char-count) 1458 force-check?) 1459 (begin 1460 (yahoo-jp-lib-set-prediction-src-string yc preconv-str) 1461 (let ((nr (yahoo-jp-lib-get-nr-predictions yc))) 1462 (if (and 1463 nr 1464 (> nr 0)) 1465 (begin 1466 (im-activate-candidate-selector 1467 yc nr yahoo-jp-nr-candidate-max) 1468 (yahoo-jp-context-set-prediction-window! yc #t) 1469 (yahoo-jp-context-set-predicting! yc #t)) 1470 (yahoo-jp-reset-prediction-window yc)))) 1471 (yahoo-jp-reset-prediction-window yc))))) 1472 1473(define (yahoo-jp-proc-input-state yc key key-state) 1474 (if (yahoo-jp-has-preedit? yc) 1475 (yahoo-jp-proc-input-state-with-preedit yc key key-state) 1476 (yahoo-jp-proc-input-state-no-preedit yc key key-state)) 1477 (if yahoo-jp-use-prediction? 1478 (yahoo-jp-check-prediction yc #f))) 1479 1480(define yahoo-jp-separator 1481 (lambda (yc) 1482 (let ((attr (bitwise-ior preedit-separator preedit-underline))) 1483 (if yahoo-jp-show-segment-separator? 1484 (cons attr yahoo-jp-segment-separator) 1485 #f)))) 1486 1487(define yahoo-jp-context-transposing-state-preedit 1488 (lambda (yc) 1489 (let ((transposing-text (yahoo-jp-transposing-text yc))) 1490 (list (cons preedit-reverse transposing-text) 1491 (cons preedit-cursor ""))))) 1492 1493(define yahoo-jp-transposing-text 1494 (lambda (yc) 1495 (let ((transposing-type (yahoo-jp-context-transposing-type yc))) 1496 (cond 1497 ((or 1498 (= transposing-type yahoo-jp-type-hiragana) 1499 (= transposing-type yahoo-jp-type-katakana) 1500 (= transposing-type yahoo-jp-type-halfkana)) 1501 (yahoo-jp-make-whole-string yc #t transposing-type)) 1502 ((= transposing-type yahoo-jp-type-halfwidth-alnum) 1503 (yahoo-jp-make-whole-raw-string yc #f #f)) 1504 ((= transposing-type yahoo-jp-candidate-type-upper-halfwidth-alnum) 1505 (yahoo-jp-make-whole-raw-string yc #f #t)) 1506 ((= transposing-type yahoo-jp-type-fullwidth-alnum) 1507 (yahoo-jp-make-whole-raw-string yc #t #f)) 1508 ((= transposing-type yahoo-jp-candidate-type-upper-fullwidth-alnum) 1509 (yahoo-jp-make-whole-raw-string yc #t #t)))))) 1510 1511(define yahoo-jp-get-raw-str-seq 1512 (lambda (yc) 1513 (let* ((rkc (yahoo-jp-context-rkc yc)) 1514 (pending (rk-pending rkc)) 1515 (residual-kana (rk-peek-terminal-match rkc)) 1516 (raw-str (yahoo-jp-context-raw-ustr yc)) 1517 (right-str (ustr-latter-seq raw-str)) 1518 (left-str (ustr-former-seq raw-str))) 1519 (append left-str 1520 (if residual-kana 1521 (if (list? (car residual-kana)) 1522 (reverse (string-to-list pending)) 1523 (list pending)) 1524 '()) 1525 right-str)))) 1526 1527(define yahoo-jp-get-raw-candidate 1528 (lambda (yc seg-idx cand-idx) 1529 (let* ((preconv 1530 (ja-join-vu (string-to-list 1531 (yahoo-jp-make-whole-string yc #t yahoo-jp-type-hiragana)))) 1532 (unconv-candidate (yahoo-jp-lib-get-unconv-candidate yc seg-idx)) 1533 (unconv (if unconv-candidate 1534 (ja-join-vu (string-to-list unconv-candidate)) 1535 '())) 1536 (raw-str (reverse (yahoo-jp-get-raw-str-seq yc)))) 1537 (cond 1538 ((= cand-idx yahoo-jp-candidate-type-hiragana) 1539 (string-list-concat unconv)) 1540 ((= cand-idx yahoo-jp-candidate-type-katakana) 1541 (ja-make-kana-str (ja-make-kana-str-list unconv) yahoo-jp-type-katakana)) 1542 ((= cand-idx yahoo-jp-candidate-type-halfkana) 1543 (ja-make-kana-str (ja-make-kana-str-list unconv) yahoo-jp-type-halfkana)) 1544 (else 1545 (if (not (null? unconv)) 1546 (if (member (car unconv) preconv) 1547 (let ((start (list-seq-contained? preconv unconv)) 1548 (len (length unconv))) 1549 (if (and 1550 start 1551 (= (length raw-str) (length preconv))) ;; sanity check 1552 (yahoo-jp-make-raw-string 1553 (reverse (sublist-rel raw-str start len)) 1554 (if (or 1555 (= cand-idx yahoo-jp-candidate-type-halfwidth-alnum) 1556 (= cand-idx 1557 yahoo-jp-candidate-type-upper-halfwidth-alnum)) 1558 #f 1559 #t) 1560 (if (or 1561 (= cand-idx yahoo-jp-candidate-type-halfwidth-alnum) 1562 (= cand-idx yahoo-jp-candidate-type-fullwidth-alnum)) 1563 #f 1564 #t)) 1565 "??")) ;; FIXME 1566 "???") ;; FIXME 1567 "????")))))) ;; shouldn't happen 1568 1569(define (yahoo-jp-predicting-state-preedit yc) 1570 (if (or 1571 (not yahoo-jp-use-implicit-commit-prediction?) 1572 (not (yahoo-jp-context-prediction-index yc))) 1573 (yahoo-jp-input-state-preedit yc) 1574 (let ((cand (yahoo-jp-get-prediction-string yc))) 1575 (list (cons (bitwise-ior preedit-reverse preedit-cursor) cand))))) 1576 1577(define (yahoo-jp-compose-state-preedit yc) 1578 (let* ((segments (yahoo-jp-context-segments yc)) 1579 (cur-seg (ustr-cursor-pos segments)) 1580 (separator (yahoo-jp-separator yc))) 1581 (append-map 1582 (lambda (seg-idx cand-idx) 1583 (let* ((attr (if (= seg-idx cur-seg) 1584 (bitwise-ior preedit-reverse 1585 preedit-cursor) 1586 preedit-underline)) 1587 (cand (if (> cand-idx yahoo-jp-candidate-type-katakana) 1588 (yahoo-jp-lib-get-nth-candidate yc seg-idx cand-idx) 1589 (yahoo-jp-get-raw-candidate yc seg-idx cand-idx))) 1590 (seg (list (cons attr cand)))) 1591 (if (and separator 1592 (< 0 seg-idx)) 1593 (cons separator seg) 1594 seg))) 1595 (iota (ustr-length segments)) 1596 (ustr-whole-seq segments)))) 1597 1598(define (yahoo-jp-input-state-preedit yc) 1599 (let* ((preconv-str (yahoo-jp-context-preconv-ustr yc)) 1600 (rkc (yahoo-jp-context-rkc yc)) 1601 (pending (rk-pending rkc)) 1602 (kana (yahoo-jp-context-kana-mode yc)) 1603 (rule (yahoo-jp-context-input-rule yc)) 1604 (extract-kana 1605 (if (= rule yahoo-jp-input-rule-kana) 1606 (lambda (entry) (car entry)) 1607 (lambda (entry) (list-ref entry kana))))) 1608 (list 1609 (and (not (ustr-cursor-at-beginning? preconv-str)) 1610 (cons preedit-underline 1611 (string-append-map-ustr-former extract-kana preconv-str))) 1612 (and (> (string-length pending) 0) 1613 (cons preedit-underline pending)) 1614 (and (yahoo-jp-has-preedit? yc) 1615 (cons preedit-cursor "")) 1616 (and (not (ustr-cursor-at-end? preconv-str)) 1617 (cons preedit-underline 1618 (string-append-map-ustr-latter extract-kana preconv-str)))))) 1619 1620(define (yahoo-jp-get-commit-string yc) 1621 (let ((segments (yahoo-jp-context-segments yc))) 1622 (string-append-map (lambda (seg-idx cand-idx) 1623 (if (> cand-idx yahoo-jp-candidate-type-katakana) 1624 (yahoo-jp-lib-get-nth-candidate 1625 yc seg-idx cand-idx) 1626 (yahoo-jp-get-raw-candidate 1627 yc seg-idx cand-idx))) 1628 (iota (ustr-length segments)) 1629 (ustr-whole-seq segments)))) 1630 1631(define (yahoo-jp-commit-string yc) 1632 (let ((yx-ctx (yahoo-jp-context-yx-ctx yc)) 1633 (segments (yahoo-jp-context-segments yc))) 1634 (if yx-ctx 1635 (begin 1636 (yahoo-jp-lib-commit-segments yc (ustr-whole-seq segments)) 1637 (if (every (lambda (x) (<= x yahoo-jp-candidate-type-katakana)) 1638 (ustr-whole-seq segments)) 1639 (yahoo-jp-lib-reset-conversion yc)))))) 1640 1641(define (yahoo-jp-do-commit yc) 1642 (im-commit yc (yahoo-jp-get-commit-string yc)) 1643 (yahoo-jp-commit-string yc) 1644 (yahoo-jp-reset-candidate-window yc) 1645 (yahoo-jp-flush yc)) 1646 1647(define (yahoo-jp-get-prediction-string yc) 1648 (yahoo-jp-lib-get-nth-prediction 1649 yc 1650 (yahoo-jp-context-prediction-index yc))) 1651 1652(define (yahoo-jp-learn-prediction-string yc) 1653 (yahoo-jp-lib-commit-nth-prediction 1654 yc 1655 (yahoo-jp-context-prediction-index yc))) 1656 1657(define (yahoo-jp-do-commit-prediction yc) 1658 (im-commit yc (yahoo-jp-get-prediction-string yc)) 1659 (yahoo-jp-learn-prediction-string yc) 1660 (yahoo-jp-reset-prediction-window yc) 1661 (yahoo-jp-flush yc)) 1662 1663(define yahoo-jp-correct-segment-cursor 1664 (lambda (segments) 1665 (if (ustr-cursor-at-end? segments) 1666 (ustr-cursor-move-backward! segments)))) 1667 1668(define (yahoo-jp-move-segment yc dir) 1669 (yahoo-jp-reset-candidate-window yc) 1670 (let ((segments (yahoo-jp-context-segments yc))) 1671 (ustr-cursor-move! segments dir) 1672 (yahoo-jp-correct-segment-cursor segments))) 1673 1674(define (yahoo-jp-resize-segment yc cnt) 1675 (let* ((segments (yahoo-jp-context-segments yc)) 1676 (cur-seg (ustr-cursor-pos segments))) 1677 (yahoo-jp-reset-candidate-window yc) 1678 (yahoo-jp-lib-resize-segment yc cur-seg cnt) 1679 (let* ((resized-nseg (yahoo-jp-lib-get-nr-segments yc)) 1680 (latter-nseg (- resized-nseg cur-seg))) 1681 (ustr-set-latter-seq! segments (make-list latter-nseg 0))))) 1682 1683(define (yahoo-jp-move-candidate yc offset) 1684 (let* ((segments (yahoo-jp-context-segments yc)) 1685 (cur-seg (ustr-cursor-pos segments)) 1686 (max (yahoo-jp-lib-get-nr-candidates yc cur-seg)) 1687 (n (if (< (ustr-cursor-frontside segments) 0) ;; segment-transposing 1688 0 1689 (+ (ustr-cursor-frontside segments) offset))) 1690 (compensated-n (cond 1691 ((>= n max) 1692 0) 1693 ((< n 0) 1694 (- max 1)) 1695 (else 1696 n))) 1697 (new-op-count (+ 1 (yahoo-jp-context-candidate-op-count yc)))) 1698 (ustr-cursor-set-frontside! segments compensated-n) 1699 (yahoo-jp-context-set-candidate-op-count! yc new-op-count) 1700 (if (and 1701 (= (yahoo-jp-context-candidate-op-count yc) 1702 yahoo-jp-candidate-op-count) 1703 yahoo-jp-use-candidate-window?) 1704 (begin 1705 (yahoo-jp-context-set-candidate-window! yc #t) 1706 (im-activate-candidate-selector yc max yahoo-jp-nr-candidate-max))) 1707 (if (yahoo-jp-context-candidate-window yc) 1708 (im-select-candidate yc compensated-n)))) 1709 1710(define yahoo-jp-move-candidate-in-page 1711 (lambda (yc numeralc) 1712 (let* ((segments (yahoo-jp-context-segments yc)) 1713 (cur-seg (ustr-cursor-pos segments)) 1714 (max (yahoo-jp-lib-get-nr-candidates yc cur-seg)) 1715 (n (ustr-cursor-frontside segments)) 1716 (cur-page (if (= yahoo-jp-nr-candidate-max 0) 1717 0 1718 (quotient n yahoo-jp-nr-candidate-max))) 1719 (pageidx (- (numeric-ichar->integer numeralc) 1)) 1720 (compensated-pageidx (cond 1721 ((< pageidx 0) ; pressing key_0 1722 (+ pageidx 10)) 1723 (else 1724 pageidx))) 1725 (idx (+ (* cur-page yahoo-jp-nr-candidate-max) compensated-pageidx)) 1726 (compensated-idx (cond 1727 ((>= idx max) 1728 (- max 1)) 1729 (else 1730 idx))) 1731 (new-op-count (+ 1 (yahoo-jp-context-candidate-op-count yc)))) 1732 (ustr-cursor-set-frontside! segments compensated-idx) 1733 (yahoo-jp-context-set-candidate-op-count! yc new-op-count) 1734 (im-select-candidate yc compensated-idx)))) 1735 1736(define (yahoo-jp-reset-candidate-window yc) 1737 (if (yahoo-jp-context-candidate-window yc) 1738 (begin 1739 (im-deactivate-candidate-selector yc) 1740 (yahoo-jp-context-set-candidate-window! yc #f))) 1741 (yahoo-jp-context-set-candidate-op-count! yc 0)) 1742 1743(define yahoo-jp-rotate-segment-transposing-alnum-type 1744 (lambda (idx state) 1745 (cond 1746 ((and 1747 (= idx yahoo-jp-candidate-type-halfwidth-alnum) 1748 (= state yahoo-jp-candidate-type-halfwidth-alnum)) 1749 yahoo-jp-candidate-type-upper-halfwidth-alnum) 1750 ((and 1751 (= idx yahoo-jp-candidate-type-fullwidth-alnum) 1752 (= state yahoo-jp-candidate-type-fullwidth-alnum)) 1753 yahoo-jp-candidate-type-upper-fullwidth-alnum) 1754 (else 1755 state)))) 1756 1757(define yahoo-jp-set-segment-transposing 1758 (lambda (yc key key-state) 1759 (let ((segments (yahoo-jp-context-segments yc))) 1760 (let ((rotate-list '()) 1761 (state #f) 1762 (idx (ustr-cursor-frontside segments))) 1763 (yahoo-jp-reset-candidate-window yc) 1764 (yahoo-jp-context-set-candidate-op-count! yc 0) 1765 1766 (if (yahoo-jp-transpose-as-fullwidth-alnum-key? key key-state) 1767 (set! rotate-list (cons yahoo-jp-candidate-type-fullwidth-alnum 1768 rotate-list))) 1769 (if (yahoo-jp-transpose-as-halfwidth-alnum-key? key key-state) 1770 (set! rotate-list (cons yahoo-jp-candidate-type-halfwidth-alnum 1771 rotate-list))) 1772 (if (yahoo-jp-transpose-as-halfkana-key? key key-state) 1773 (set! rotate-list (cons yahoo-jp-candidate-type-halfkana 1774 rotate-list))) 1775 (if (yahoo-jp-transpose-as-katakana-key? key key-state) 1776 (set! rotate-list (cons yahoo-jp-candidate-type-katakana 1777 rotate-list))) 1778 (if (yahoo-jp-transpose-as-hiragana-key? key key-state) 1779 (set! rotate-list (cons yahoo-jp-candidate-type-hiragana 1780 rotate-list))) 1781 (if (or 1782 (= idx yahoo-jp-candidate-type-hiragana) 1783 (= idx yahoo-jp-candidate-type-katakana) 1784 (= idx yahoo-jp-candidate-type-halfkana) 1785 (= idx yahoo-jp-candidate-type-halfwidth-alnum) 1786 (= idx yahoo-jp-candidate-type-fullwidth-alnum) 1787 (= idx yahoo-jp-candidate-type-upper-halfwidth-alnum) 1788 (= idx yahoo-jp-candidate-type-upper-fullwidth-alnum)) 1789 (let ((lst (member idx rotate-list))) 1790 (if (and lst 1791 (not (null? (cdr lst)))) 1792 (set! state (car (cdr lst))) 1793 (set! state (yahoo-jp-rotate-segment-transposing-alnum-type 1794 idx (car rotate-list))))) 1795 (set! state (car rotate-list))) 1796 (ustr-cursor-set-frontside! segments state))))) 1797 1798(define (yahoo-jp-proc-compose-state yc key key-state) 1799 (cond 1800 ((yahoo-jp-prev-page-key? key key-state) 1801 (if (yahoo-jp-context-candidate-window yc) 1802 (im-shift-page-candidate yc #f))) 1803 1804 ((yahoo-jp-next-page-key? key key-state) 1805 (if (yahoo-jp-context-candidate-window yc) 1806 (im-shift-page-candidate yc #t))) 1807 1808 ((yahoo-jp-commit-key? key key-state) 1809 (yahoo-jp-do-commit yc)) 1810 1811 ((yahoo-jp-extend-segment-key? key key-state) 1812 (yahoo-jp-resize-segment yc 1)) 1813 1814 ((yahoo-jp-shrink-segment-key? key key-state) 1815 (yahoo-jp-resize-segment yc -1)) 1816 1817 ((yahoo-jp-next-segment-key? key key-state) 1818 (yahoo-jp-move-segment yc 1)) 1819 1820 ((yahoo-jp-prev-segment-key? key key-state) 1821 (yahoo-jp-move-segment yc -1)) 1822 1823 ((yahoo-jp-beginning-of-preedit-key? key key-state) 1824 (begin 1825 (ustr-cursor-move-beginning! (yahoo-jp-context-segments yc)) 1826 (yahoo-jp-reset-candidate-window yc))) 1827 1828 ((yahoo-jp-end-of-preedit-key? key key-state) 1829 (begin 1830 (ustr-cursor-move-end! (yahoo-jp-context-segments yc)) 1831 (yahoo-jp-correct-segment-cursor (yahoo-jp-context-segments yc)) 1832 (yahoo-jp-reset-candidate-window yc))) 1833 1834 ((yahoo-jp-backspace-key? key key-state) 1835 (yahoo-jp-cancel-conv yc)) 1836 1837 ((yahoo-jp-next-candidate-key? key key-state) 1838 (yahoo-jp-move-candidate yc 1)) 1839 1840 ((yahoo-jp-prev-candidate-key? key key-state) 1841 (yahoo-jp-move-candidate yc -1)) 1842 1843 ((or (yahoo-jp-transpose-as-hiragana-key? key key-state) 1844 (yahoo-jp-transpose-as-katakana-key? key key-state) 1845 (yahoo-jp-transpose-as-halfkana-key? key key-state) 1846 (and 1847 (not (= (yahoo-jp-context-input-rule yc) yahoo-jp-input-rule-kana)) 1848 (or 1849 (yahoo-jp-transpose-as-halfwidth-alnum-key? key key-state) 1850 (yahoo-jp-transpose-as-fullwidth-alnum-key? key key-state)))) 1851 (yahoo-jp-set-segment-transposing yc key key-state)) 1852 1853 ((yahoo-jp-cancel-key? key key-state) 1854 (yahoo-jp-cancel-conv yc)) 1855 1856 ((and yahoo-jp-select-candidate-by-numeral-key? 1857 (ichar-numeric? key) 1858 (yahoo-jp-context-candidate-window yc)) 1859 (yahoo-jp-move-candidate-in-page yc key)) 1860 1861 ((and (modifier-key-mask key-state) 1862 (not (shift-key-mask key-state))) 1863 #f) 1864 1865 ((symbol? key) 1866 #f) 1867 1868 (else 1869 (begin 1870 (yahoo-jp-do-commit yc) 1871 (yahoo-jp-proc-input-state yc key key-state))))) 1872 1873(define (yahoo-jp-press-key-handler yc key key-state) 1874 (if (ichar-control? key) 1875 (im-commit-raw yc) 1876 (if (yahoo-jp-context-on yc) 1877 (if (yahoo-jp-context-transposing yc) 1878 (yahoo-jp-proc-transposing-state yc key key-state) 1879 (if (yahoo-jp-context-state yc) 1880 (yahoo-jp-proc-compose-state yc key key-state) 1881 (if (yahoo-jp-context-predicting yc) 1882 (yahoo-jp-proc-prediction-state yc key key-state) 1883 (yahoo-jp-proc-input-state yc key key-state)))) 1884 (yahoo-jp-proc-raw-state yc key key-state))) 1885 (yahoo-jp-update-preedit yc)) 1886 1887;;; 1888(define (yahoo-jp-release-key-handler yc key key-state) 1889 (if (or (ichar-control? key) 1890 (not (yahoo-jp-context-on yc))) 1891 (yahoo-jp-commit-raw yc))) 1892;;; 1893(define (yahoo-jp-reset-handler yc) 1894 (if (yahoo-jp-context-on yc) 1895 (begin 1896 (if (yahoo-jp-context-state yc) 1897 (yahoo-jp-lib-reset-conversion yc)) 1898 (yahoo-jp-flush yc)))) 1899 1900;;; 1901(define (yahoo-jp-get-candidate-handler yc idx ascel-enum-hint) 1902 (let* ((cur-seg (ustr-cursor-pos (yahoo-jp-context-segments yc))) 1903 (cand (if (yahoo-jp-context-state yc) 1904 (yahoo-jp-lib-get-nth-candidate yc cur-seg idx) 1905 (yahoo-jp-lib-get-nth-prediction yc idx)))) 1906 (list cand (digit->string (+ idx 1)) ""))) 1907 1908(define (yahoo-jp-set-candidate-index-handler yc idx) 1909 (cond 1910 ((yahoo-jp-context-state yc) 1911 (ustr-cursor-set-frontside! (yahoo-jp-context-segments yc) idx) 1912 (yahoo-jp-update-preedit yc)) 1913 ((yahoo-jp-context-predicting yc) 1914 (yahoo-jp-context-set-prediction-index! yc idx) 1915 (yahoo-jp-update-preedit yc)))) 1916 1917(define (yahoo-jp-proc-raw-state yc key key-state) 1918 (if (not (yahoo-jp-begin-input yc key key-state)) 1919 (im-commit-raw yc))) 1920 1921(yahoo-jp-configure-widgets) 1922(register-im 1923 'yahoo-jp 1924 "ja" 1925 "EUC-JP" 1926 yahoo-jp-im-name-label 1927 yahoo-jp-im-short-desc 1928 #f 1929 yahoo-jp-init-handler 1930 yahoo-jp-release-handler 1931 context-mode-handler 1932 yahoo-jp-press-key-handler 1933 yahoo-jp-release-key-handler 1934 yahoo-jp-reset-handler 1935 yahoo-jp-get-candidate-handler 1936 yahoo-jp-set-candidate-index-handler 1937 context-prop-activate-handler 1938 #f 1939 #f 1940 #f 1941 #f 1942 #f 1943 ) 1944