1;;; 2;;; Copyright (c) 2003-2013 uim Project https://github.com/uim/uim 3;;; 4;;; All rights reserved. 5;;; 6;;; Redistribution and use in source and binary forms, with or without 7;;; modification, are permitted provided that the following conditions 8;;; are met: 9;;; 1. Redistributions of source code must retain the above copyright 10;;; notice, this list of conditions and the following disclaimer. 11;;; 2. Redistributions in binary form must reproduce the above copyright 12;;; notice, this list of conditions and the following disclaimer in the 13;;; documentation and/or other materials provided with the distribution. 14;;; 3. Neither the name of authors nor the names of its contributors 15;;; may be used to endorse or promote products derived from this software 16;;; without specific prior written permission. 17;;; 18;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND 19;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21;;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE 22;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 24;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 25;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 26;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 27;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 28;;; SUCH DAMAGE. 29;;;; 30 31(require-extension (srfi 95)) 32 33(require-custom "generic-key-custom.scm") 34(require-custom "look-custom.scm") 35 36(require "annotation.scm") 37 38;; widgets 39(define look-widgets '(widget_look_input_mode)) 40 41;; default activity for each widgets 42(define default-widget_look_input_mode 'action_look_sleep) 43 44;; actions of widget_look_input_mode 45(define look-input-mode-actions 46 '(action_look_sleep action_look_direct action_look_look)) 47 48;;; implementations 49 50(register-action 'action_look_sleep 51 (lambda (lc) 52 (list 53 'look_sleep_input 54 "_" 55 (N_ "Sleep") 56 (N_ "Look Sleep Input Mode"))) 57 (lambda (lc) 58 (not (look-context-on? lc))) 59 (lambda (lc) 60 (look-context-set-on! lc #f))) 61 62(register-action 'action_look_direct 63 (lambda (lc) 64 (list 65 'look_direct_input 66 "-" 67 (N_ "Direct") 68 (N_ "Look Direct Input Mode"))) 69 (lambda (lc) 70 (and (look-context-on? lc) 71 (not (look-context-look? lc)))) 72 (lambda (lc) 73 (look-context-set-on! lc #t) 74 (look-context-set-look! lc #f))) 75 76(register-action 'action_look_look 77 (lambda (lc) 78 (list 79 'look_input 80 "e" ;; do you like nethack? 81 (N_ "Look") 82 (N_ "Look Input Mode"))) 83 (lambda (lc) 84 (and (look-context-on? lc) 85 (look-context-look? lc))) 86 (lambda (lc) 87 (look-context-set-on! lc #t) 88 (look-context-set-look! lc #t))) 89 90;; Update widget definitions based on action configurations. The 91;; procedure is needed for on-the-fly reconfiguration involving the 92;; custom API 93(define (look-configure-widgets) 94 (register-widget 'widget_look_input_mode 95 (activity-indicator-new look-input-mode-actions) 96 (actions-new look-input-mode-actions))) 97 98(define look-context-rec-spec 99 (append 100 context-rec-spec 101 (list 102 (list 'on #f) 103 (list 'look #f) 104 (list 'nth 0) 105 (list 'candidates ()) 106 (list 'left "") 107 (list 'prev ()) ; simple queue: ([string]prevword1 prevword2 ...) 108 (list 'dict #f) ; list ((([string]prevword1 prevword2 ...) . [alist]history) ...) 109 (list 'dictlen 0)))) 110(define look-context-rec-spec look-context-rec-spec) 111(define-record 'look-context look-context-rec-spec) 112(define look-context-new-internal look-context-new) 113 114;; XXX: fake R5RS functions 115(define (look-internal:string->list s) 116 (map (lambda (c) 117 (string->symbol c)) 118 (reverse (string-to-list s)))) 119(define (look-internal:list->string l) 120 (apply string-append 121 (map (lambda (x) 122 (symbol->string x)) 123 l))) 124(define (look-internal:make-string n c) 125 (apply string-append (map (lambda (x) (symbol->string c)) (iota n)))) 126(define (look-to-lower-string str) 127 (apply string-append 128 (map (lambda (c) 129 (if (ichar-upper-case? (string->charcode c)) 130 (charcode->string (ichar-downcase (string->charcode c))) 131 c)) 132 (reverse (string-to-list str))))) 133 134(define (look-history-sort li lessf) 135 ;;(map car li)) 136 (map car (sort! li (lambda (x y) (lessf (cdr x) (cdr y)))))) 137 138(define (look-history-eow? x) 139 (eq? #t (car x))) 140(define (look-init-history seedf) 141 (list (cons #t (seedf)))) 142(define (look-make-eow stat) 143 (cons #t stat)) 144(define (look-histroy-append str hist seedf eowf) 145 (let ((cs (look-internal:string->list str))) 146 (cond ((null? cs) 147 (if (assq #t hist) ; eow? 148 (map (lambda (x) 149 (if (look-history-eow? x) 150 (look-make-eow (eowf (cdr x))) 151 x)) 152 hist) 153 (append (list (look-make-eow (seedf))) hist))) 154 ((and (not (null? hist)) 155 (assoc (car cs) hist)) 156 (map (lambda (x) 157 (if (equal? (car cs) (car x)) 158 (cons (car cs) 159 (look-histroy-append 160 (look-internal:list->string (cdr cs)) 161 (cdr x) 162 seedf eowf)) 163 x)) 164 hist)) 165 (else 166 (append (list (cons (car cs) 167 (look-histroy-append 168 (look-internal:list->string (cdr cs)) 169 '() 170 seedf eowf))) 171 hist))))) 172(define (look-history-search str hist) 173 (define (skip str hist) 174 (let ((cs (look-internal:string->list str))) 175 (if (null? cs) 176 hist 177 (let ((c (assoc (car cs) hist))) 178 (if c 179 (skip (look-internal:list->string (cdr cs)) (cdr c)) 180 '()))))) 181 (define (connect-tree hist) 182 (let loop ((hist hist) (rest "")) 183 (cond ((null? hist) 184 '()) 185 ((find (lambda (x) (not (look-history-eow? x))) hist) 186 (apply 187 append (map (lambda (l) 188 (let ((li (loop (cdr l) 189 (string-append rest (look-internal:make-string 1 (car l)))))) 190 (if (list? li) 191 li 192 (list li)))) 193 (filter (lambda (x) (not (look-history-eow? x))) hist)))) 194 (else 195 (cons rest (cdar hist)))))) 196 (connect-tree (filter (lambda (x) (not (look-history-eow? x))) 197 (skip str hist)))) 198 199;; accumulator 200(define (look-history-stat-init) 201 1) 202(define (look-history-stat-inc x) 203 (+ 1 x)) 204(define (look-history-stat-less x y) 205 (> x y)) 206 207;; XXX: non-atomic functions 208(define (look-save-personal-dict lc) 209 (call-with-output-file look-personal-dict-filename 210 (lambda (port) 211 (im-clear-preedit lc) 212 (im-pushback-preedit 213 lc preedit-reverse 214 "[saving...]") 215 (im-update-preedit lc) 216 (write (cons look-prepared-words 217 (look-context-dict lc)) 218 port) 219 (im-clear-preedit lc) 220 (im-update-preedit lc)))) 221 222(define (look-load-personal-dict lc) 223 (if (file-readable? look-personal-dict-filename) 224 (let ((dict (call-with-input-file look-personal-dict-filename 225 (lambda (port) 226 (im-clear-preedit lc) 227 (im-pushback-preedit 228 lc preedit-reverse 229 "[loading...]") 230 (im-update-preedit lc) 231 (guard (err 232 (else #f)) 233 (read port)))))) 234 (if (and dict 235 (not (null? dict)) 236 (= (car dict) look-prepared-words)) 237 (look-context-set-dict! lc (cdr dict))))) 238 (im-clear-preedit lc) 239 (im-update-preedit lc)) 240 241(define (look-learn lc) 242 (define (histroy-append hist) 243 (look-histroy-append (look-to-lower-string (look-context-left lc)) 244 hist 245 look-history-stat-init 246 look-history-stat-inc)) 247 (cond ((= 0 look-prepared-words) 248 (let ((hist (if (not (look-context-dict lc)) 249 (look-init-history look-history-stat-init) 250 (look-context-dict lc)))) 251 (look-context-set-dict! 252 lc 253 (histroy-append hist)))) 254 ((< (length (look-context-prev lc)) look-prepared-words) 255 #t) 256 (else 257 (if (not (look-context-dict lc)) 258 (look-context-set-dict! 259 lc 260 (cons (look-context-prev lc) 261 (histroy-append (look-init-history look-history-stat-init)))) 262 (if (assoc (look-context-prev lc) 263 (look-context-dict lc)) 264 (look-context-set-dict! 265 lc 266 (map (lambda (x) 267 (if (equal? (look-context-prev lc) 268 (car x)) 269 (cons (car x) 270 (histroy-append (cdr x))) 271 x)) 272 (look-context-dict lc))) 273 (look-context-set-dict! 274 lc 275 (append (list (cons (look-context-prev lc) 276 (histroy-append (look-init-history look-history-stat-init)))) 277 (look-context-dict lc))))))) 278 (if (< (length (look-context-prev lc)) look-prepared-words) 279 (look-context-set-prev! lc (append (look-context-prev lc) 280 (list (string->symbol (look-context-left lc))))) 281 (if (= 0 look-prepared-words) 282 #t 283 (look-context-set-prev! lc (append (cdr (look-context-prev lc)) 284 (list (string->symbol (look-context-left lc)))))))) 285 286(define (look-search-learned lc str) 287 (if (= 0 look-prepared-words) 288 (if (look-context-dict lc) 289 (look-history-sort 290 (look-history-search (look-to-lower-string str) 291 (look-context-dict lc)) 292 look-history-stat-less) 293 '()) 294 (let ((res (if (look-context-dict lc) 295 (assoc (look-context-prev lc) (look-context-dict lc)) 296 #f))) 297 (if res 298 (look-history-sort 299 (look-history-search (look-to-lower-string (look-context-left lc)) 300 (cdr res)) 301 look-history-stat-less) 302 '())))) 303 304(define look-context-on? look-context-on) 305(define look-context-look? look-context-look) 306 307(define (look-get-nth-candidate lc) 308 (if (< 0 (length (look-context-candidates lc))) 309 (nth (look-context-nth lc) (look-context-candidates lc)) 310 "")) 311 312(define (look-get-length-left lc) 313 (string-length (look-context-left lc))) 314 315(define (look-append-left! lc str) 316 (look-context-set-left! lc (string-append (look-context-left lc) str))) 317 318(define (look-remove-last-char-from-left! lc) 319 (let ((left (look-context-left lc))) 320 (if (< 0 (look-get-length-left lc)) 321 (look-context-set-left! lc (apply string-append (reverse (cdr (string-to-list left))))) 322 (look-context-set-left! lc "")))) 323 324(define (look-append-char-from-candidate-to-left! lc) 325 (let ((candidate (look-get-nth-candidate lc))) 326 (if (< 0 (string-length candidate)) 327 (look-context-set-left! lc (string-append (look-context-left lc) 328 (car (reverse (string-to-list candidate)))))))) 329 330(define (look-append-from-candidate-to-left! lc) 331 (look-context-set-left! lc (string-append (look-context-left lc) 332 (look-get-nth-candidate lc))) 333 (look-context-set-candidates! lc '())) 334 335(define (look-context-new . args) 336 (let ((lc (apply look-context-new-internal args))) 337 (look-context-set-widgets! lc look-widgets) 338 (if look-use-annotation? 339 (annotation-init)) 340 lc)) 341 342(define (look-context-clean lc) 343 (look-context-set-on! lc #f) 344 (look-context-set-look! lc #f) 345 (look-context-set-nth! lc 0) 346 (look-context-set-candidates! lc '()) 347 (look-context-set-left! lc "")) 348 349(define (look-context-flush lc) 350 (look-learn lc) 351 (im-commit lc (look-context-left lc)) 352 (look-context-set-look! lc #f) 353 (look-context-set-nth! lc 0) 354 (look-context-set-candidates! lc '()) 355 (look-context-set-left! lc "")) 356 357(define (look-push-back-mode lc lst) 358 (if (car lst) 359 (begin 360 (im-pushback-mode-list lc (caar lst)) 361 (look-push-back-mode lc (cdr lst))))) 362 363(define (look-init-handler id im arg) 364 (let ((lc (look-context-new id im))) 365 (look-load-personal-dict lc) 366 lc)) 367 368(define (look-release-handler lc) 369 (if look-use-annotation? 370 (annotation-release)) 371 #f) 372 373(define (look-alphabetic-char? key state) 374 (and (or (not (modifier-key-mask state)) 375 (shift-key-mask state)) 376 (ichar-alphabetic? key))) 377 378(define (look-next-candidate! lc) 379 (if (< (look-context-nth lc) (- (length (look-context-candidates lc)) 1)) 380 (look-context-set-nth! lc (+ (look-context-nth lc) 1)))) 381 382(define (look-prev-candidate! lc) 383 (if (< 0 (look-context-nth lc)) 384 (look-context-set-nth! lc (- (look-context-nth lc) 1)))) 385 386(define (look-look lc look-dict str) 387 (let* ((learned (look-search-learned lc str)) 388 (looked (look-lib-look #t #t look-candidates-max look-dict str))) 389 (look-context-set-dictlen! lc (length learned)) 390 (append learned (if looked looked '())))) 391 392(define (look-update lc) 393 (let ((str (look-context-left lc))) 394 (look-context-set-nth! lc 0) 395 (if (<= look-beginning-character-length (string-length str)) 396 (look-context-set-candidates! lc (look-look lc look-dict str)) 397 (look-context-set-candidates! lc '())))) 398 399(define (look-format-candidates lc) 400 (let ((candidates (look-context-candidates lc))) 401 (if (or (= 0 (string-length (look-context-left lc))) 402 (<= (length candidates) (look-context-nth lc))) 403 "" 404 (string-append look-fence-left 405 (nth (look-context-nth lc) candidates) 406 look-fence-right)))) 407 408(define (look-format-candidates-nth lc) 409 (if (or (= 0 (string-length (look-context-left lc))) 410 (<= (length (look-context-candidates lc)) 411 (look-context-nth lc))) 412 "" 413 (let ((nth (if (< (look-context-nth lc) 414 (look-context-dictlen lc)) 415 (+ 1 (look-context-nth lc)) 416 (+ 1 417 (- (look-context-nth lc) 418 (look-context-dictlen lc))))) 419 (candidates (if (< (look-context-nth lc) 420 (look-context-dictlen lc)) 421 (look-context-dictlen lc) 422 (- (length (look-context-candidates lc)) 423 (look-context-dictlen lc))))) 424 (string-append "[" 425 (number->string nth) 426 "/" 427 (number->string candidates) 428 "]")))) 429 430(define (look-format-annotation lc) 431 (define (annotation-format-entry str lines) 432 (let loop ((l (string->list str)) 433 (lines lines) 434 (rest '())) 435 (cond ((or (null? l) 436 (= 0 lines)) 437 (list->string (reverse rest))) 438 ((eq? #\newline (car l)) 439 (loop (cdr l) (- lines 1) (cons #\space rest))) 440 (else 441 (loop (cdr l) lines (cons (car l) rest)))))) 442 (let ((candidates (look-context-candidates lc))) 443 (if (or (= 0 (string-length (look-context-left lc))) 444 (<= (length candidates) (look-context-nth lc))) 445 "" 446 (annotation-format-entry (annotation-get-text (string-append 447 (look-context-left lc) 448 (nth (look-context-nth lc) candidates)) 449 "UTF-8") 450 look-annotation-show-lines)))) 451 452 453(define (look-update-preedit lc) 454 (im-clear-preedit lc) 455 (im-pushback-preedit 456 lc preedit-none 457 (look-context-left lc)) 458 (im-pushback-preedit 459 lc preedit-cursor 460 (look-format-candidates lc)) 461 (if (< (look-context-nth lc) (look-context-dictlen lc)) 462 (im-pushback-preedit 463 lc preedit-none 464 (look-format-candidates-nth lc)) 465 (im-pushback-preedit 466 lc preedit-reverse 467 (look-format-candidates-nth lc))) 468 (if look-use-annotation? 469 (im-pushback-preedit 470 lc preedit-none 471 (look-format-annotation lc))) 472 (im-update-preedit lc)) 473 474(define (look-key-press-state-look lc key state) 475 (cond ((look-off-key? key state) 476 (look-context-clean lc) 477 (look-update-preedit lc)) 478 ((look-alphabetic-char? key state) 479 (look-append-left! lc (charcode->string key)) 480 (look-update lc) 481 (look-update-preedit lc)) 482 ((look-completion-key? key state) 483 (look-append-from-candidate-to-left! lc) 484 (look-context-flush lc) 485 (look-update-preedit lc)) 486 ((and (look-next-char-key? key state) 487 (< 0 (look-get-length-left lc))) 488 (look-append-char-from-candidate-to-left! lc) 489 (look-update lc) 490 (look-update-preedit lc)) 491 ((look-prev-char-key? key state) 492 (cond ((<= (look-get-length-left lc) 0) 493 (look-context-flush lc) 494 ;; or (look-context-clean lc) 495 (im-commit-raw lc)) 496 (else 497 (look-remove-last-char-from-left! lc))) 498 (look-update lc) 499 (look-update-preedit lc)) 500 ((look-next-candidate-key? key state) 501 (look-next-candidate! lc) 502 (look-update-preedit lc)) 503 ((look-prev-candidate-key? key state) 504 (look-prev-candidate! lc) 505 (look-update-preedit lc)) 506 ((look-save-dict-key? key state) 507 (look-save-personal-dict lc) 508 (im-commit-raw lc) 509 (look-context-flush lc) 510 (look-update-preedit lc)) 511 ((look-load-dict-key? key state) 512 (look-load-personal-dict lc) 513 (im-commit-raw lc) 514 (look-context-flush lc) 515 (look-update-preedit lc)) 516 (else 517 (im-commit-raw lc) 518 (look-context-flush lc) 519 (look-update-preedit lc)))) 520 521(define (look-key-press-state-direct lc key state) 522 (cond ((look-off-key? key state) 523 (look-context-clean lc) 524 (look-update-preedit lc)) 525 ((look-alphabetic-char? key state) 526 (look-context-set-left! lc (charcode->string key)) 527 (look-update lc) 528 (look-update-preedit lc) 529 (look-context-set-look! lc #t)) 530 ((look-save-dict-key? key state) 531 (look-save-personal-dict lc) 532 (im-commit-raw lc)) 533 ((look-load-dict-key? key state) 534 (look-load-personal-dict lc) 535 (im-commit-raw lc)) 536 (else 537 (im-commit-raw lc)))) 538 539(define (look-key-press-state-sleep lc key state) 540 (cond ((look-on-key? key state) 541 (look-context-set-on! lc #t) 542 (look-context-set-look! lc #f)) 543 (else 544 (im-commit-raw lc)))) 545 546(define (look-key-press-handler lc key state) 547 (if (look-context-on? lc) 548 (if (look-context-look? lc) 549 (look-key-press-state-look lc key state) 550 (look-key-press-state-direct lc key state)) 551 (look-key-press-state-sleep lc key state))) 552 553(define (look-key-release-handler lc key state) 554 (im-commit-raw lc)) 555 556(define (look-reset-handler lc) 557 #f) 558 559;;(define (look-mode-handler lc mode) 560;; (create-context (look-context-id lc) 561;; #f 562;; (car (nth mode im-list))) 563;; #f) 564 565(define (look-get-candidate-handler lc idx) 566 #f) 567 568(define (look-set-candidate-index-handler lc idx) 569 #f) 570 571(look-configure-widgets) 572 573(register-im 574 'look 575 "" 576 "UTF-8" 577 (N_ "Look") 578 (N_ "Tiny predictive input method") 579 #f 580 look-init-handler 581 look-release-handler 582 context-mode-handler 583 look-key-press-handler 584 look-key-release-handler 585 look-reset-handler 586 look-get-candidate-handler 587 look-set-candidate-index-handler 588 context-prop-activate-handler 589 #f 590 #f 591 #f 592 #f 593 #f 594 ) 595