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