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