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