;;;
;;; Copyright (c) 2003,2004 uim Project http://uim.freedesktop.org/
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;;    notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;;    notice, this list of conditions and the following disclaimer in the
;;;    documentation and/or other materials provided with the distribution.
;;; 3. Neither the name of authors nor the names of its contributors
;;;    may be used to endorse or promote products derived from this software
;;;    without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
;;; SUCH DAMAGE.
;;;;

;;uim-spellcheck is dynamic spell checker.

(require "generic-key.scm")


;; configs
(define spell-use-candidate-window? #t)
(define spell-candidate-op-count 1) ;;候補ウィンドウを表示するまでに何回スペースキーを押す必要があるか？
(define spell-preedit-immididate-commit? #f)
(define spell-always-show-window? #t)

;; key
(define-key spell-on-key? '("<Control>j" "<Control>J" generic-on-key?))

;; access
(define spell-context-immediate-commit ;;一時的にspell-preedit-immididate-commit?をオフにするかどうか
 (lambda (ac)
   (car (nthcdr 15 ac))))

(define spell-context-set-immediate-commit!
  (lambda (ac mode)
    (set-car! (nthcdr 15 ac) mode)))

(define spell-context-last-word ;;SPELLやPOBoxの用語でいうContext
 (lambda (ac)
   (car (nthcdr 14 ac))))

(define spell-context-set-last-word!
  (lambda (ac mode)
    (set-car! (nthcdr 14 ac) mode)))

(define spell-context-mode
 (lambda (ac)
   (car (nthcdr 13 ac))))

(define spell-context-set-mode!
  (lambda (ac mode)
    (set-car! (nthcdr 13 ac) mode)))

(define spell-context-left-string ;;カーソルの左側にあるpreedit文字列のリスト
 (lambda (ac)
   (car (nthcdr 12 ac))))

(define spell-context-set-left-string!
  (lambda (ac str)
    (set-car! (nthcdr 12 ac) str)))

(define spell-context-right-string
 (lambda (ac)
   (car (nthcdr 11 ac))))

(define spell-context-set-right-string!
  (lambda (ac str)
    (set-car! (nthcdr 11 ac) str)))

(define spell-context-candidates
  (lambda (c)
   (car (nthcdr 10 c))))

(define spell-context-set-candidates!
  (lambda (c cnt)
    (set-car! (nthcdr 10 c) cnt)))

(define spell-context-candidate-window
  (lambda (c)
   (car (nthcdr 9 c))))

(define spell-context-set-candidate-window!
  (lambda (c cnt)
    (set-car! (nthcdr 9 c) cnt)))

(define spell-context-candidate-op-count
  (lambda (c)
   (car (nthcdr 8 c))))
    
(define spell-context-set-candidate-op-count!
  (lambda (c cnt)
    (set-car! (nthcdr 8 c) cnt)))

(define spell-context-rk-context
  (lambda (c)
   (car (nthcdr 7 c))))

(define spell-context-set-rk-context!
  (lambda (c rkc)
    (set-car! (nthcdr 7 c) rkc)))

(define spell-context-nth
  (lambda (c)
    (car (nthcdr 6 c))))

(define spell-context-set-nth!
  (lambda (c nth)
    (set-car! (nthcdr 6 c) nth)))

(define spell-context-tail
  (lambda (c)
    (car (nthcdr 4 c))))

(define spell-context-set-tail!
  (lambda (c tail)
    (set-car! (nthcdr 4 c) tail)))

(define spell-context-set-head!
  (lambda (c head)
    (set-car! (nthcdr 2 c) head)))

(define spell-context-head
  (lambda (c)
    (car (nthcdr 2 c))))

(define spell-context-kana-mode
  (lambda (sc)
    (car (nthcdr 1 sc))))

(define spell-context-set-kana-mode!
  (lambda (sc mode)
    (set-car! (nthcdr 1 sc) mode)))

(define spell-context-state
  (lambda (c)
    (car (nthcdr 0 c))))

(define spell-context-set-state!
  (lambda (c s)
    (set-car! (nthcdr 0 c) s)))
;; state kana head okuri tail candidates nth rk

(define spell-flush
  (lambda (sc)
    (spell-context-set-state! sc 'spell-state-no-preedit)
    (spell-context-set-head! sc '())
    (spell-context-set-immediate-commit! sc #t)
    (spell-context-set-tail! sc '())
    (spell-context-set-left-string! sc '())
    (spell-context-set-right-string! sc '())
    (spell-context-set-nth! sc #f)
    (spell-context-set-candidate-window! sc #f)))


(define spell-context-new
  (lambda ()
    (let ((c 
	   (copy-list 
	    '(spell-state-latin #t "" "" "" () () () () () () () () 0 "" #t))))
      (spell-context-set-head! c ())
      (spell-flush c)
      (spell-context-set-state! c 'spell-state-latin)
      c)))

(define spell-make-string
  (lambda (sc sl dir)  ;;dirは文字列の方向を表す(カーソルより右側の文字列は向きが逆になってる)
    (let ((kana?))
      (if (= 1 (spell-context-mode sc))
	  (set! kana? #t))
      (if (= 2 (spell-context-mode sc))
	  (set! kana? #f))
      (if sl
	  (if dir
	      (string-append (spell-make-string sc (cdr sl) dir)
			     (if kana?
				 (caar sl)
				 (cdar sl)))
	      (string-append (if kana?
				 (caar sl)
				 (cdar sl))
			     (spell-make-string sc (cdr sl) dir)))
	  ""))))

(define spell-context-kana-toggle
  (lambda (sc)
    (let ((s (spell-context-kana-mode sc)))
      (set! s (not s))
      (if s
	  (spell-context-set-mode! sc 1)
	  (spell-context-set-mode! sc 2))
      (spell-context-set-kana-mode! sc s))))

(define spell-get-string-by-mode
  (lambda (sc res)
    (if res
	(if (spell-context-kana-mode sc)
	    (car res)
	    (cdr res))
	#f)))

(define spell-get-nth-candidate
  (lambda (sc n)
    (if (> n (spell-get-nr-candidates sc))
	#f)
    (car (cdr (car (nthcdr n (spell-context-candidates sc)))))
    ))

(define spell-get-nr-candidates
  (lambda (sc)
    (length (spell-context-candidates sc))))

(define spell-get-current-candidate
  (lambda (sc)
    (spell-get-nth-candidate
     sc
     (spell-context-nth sc))))

(define spell-get-candidates! ;;もうちょっと関数名をどうにかしたい
  (lambda (sc preedit context)
	(let ((tmp))
	  (spell-lib-send-command (string-append "set_context\t"  context "\n"))
	  (spell-context-set-candidates!
	   sc
	   (spell-parse-cands
		(spell-lib-send-command (string-append "l\t"  preedit "\n"))))
	  )))

(define spell-make-assoc-list
  (lambda (lst)
	(mapcar 
	 (lambda (str)
	   (string-split str "="))
	 lst)))

(define spell-commit-candidate
  (lambda (sc)
	(let ((nth (spell-context-nth sc)))
	  (set! assoc-list 
			(spell-make-assoc-list 
			 (cddar (nthcdr nth (spell-context-candidates sc)))))
	  (spell-learn-word sc assoc-list)
	  )))

(define spell-learn-word
  (lambda (sc assoc-list)
    (let ((key     (or (cadr (assoc "basekey"     assoc-list)) ""))
	  (value   (or (cadr (assoc "base"        assoc-list)) ""))
	  (part    (or (cadr (assoc "part"        assoc-list)) ""))
	  (context (or (spell-context-last-word sc) ""))
	  (suffix  (or (cadr (assoc "conjugation" assoc-list)) ""))
	  (rest    (or (cadr (assoc "suffix"      assoc-list)) "")))

	  (spell-lib-send-command
	   (string-append "learn_word\t" key "\t" value "\t" part "\t" context "\t" suffix "\t" rest "\n"))

	  (spell-context-set-last-word!
	   sc
	   (spell-get-current-candidate sc))
	  )))

(define spell-parse-cands
  (lambda (cands-string)
	(mapcar
	 (lambda (str-line)
	   (string-split str-line "\t"))
	 (cdr (delq "" (string-split cands-string "\n"))))))

(define spell-begin-conversion
  (lambda (sc id)
    (let ((res))
	  (spell-get-candidates!
	   sc 
	   (spell-make-string sc (spell-context-left-string sc) #t)
	   (spell-context-last-word sc))
      (set! res
	    (spell-get-nth-candidate sc 0))
      (if res
	  (begin
	    (spell-context-set-nth! sc 0)
	    (spell-context-set-state!
	     sc 'spell-state-converting))
	  (spell-flush sc))
      ())))

(define spell-update-preedit
  (lambda (id sc)
    (let ((rkc (spell-context-rk-context sc))
	  (stat (spell-context-state sc)))
      (im-clear-preedit id)
      (if (= stat 'spell-state-converting)
	  (begin
	    (im-pushback-preedit
	     id preedit-reverse
	     (spell-get-current-candidate sc)))
	  (if (spell-has-preedit? sc)
	      (let ((hl (spell-make-string
			 sc (spell-context-left-string sc) #t))
		    (hr (spell-make-string
			 sc (spell-context-right-string sc) #f)))
		(if (string? hl)
		    (im-pushback-preedit
		     id preedit-underline
		     hl))
		(im-pushback-preedit id preedit-underline
				     (rk-pending rkc))
		(im-pushback-preedit id preedit-cursor "")
		(if (string? hr)
		    (im-pushback-preedit
		     id preedit-underline
		     hr)))))
      (im-update-preedit id))))

(define spell-update-mode
  (lambda (id sc)
    (let ((mode (spell-context-mode sc)))
      (im-update-mode id mode))))

(define spell-update-candidate-window
  (lambda (sc id)
    (if (and
	 (spell-has-preedit? sc)
	 (not (spell-context-candidate-window sc))
	 (or spell-always-show-window?
	     (> (spell-context-candidate-op-count sc)
		spell-candidate-op-count)))
	(begin
	  (spell-get-candidates!
	   sc
	   (spell-make-string sc (spell-context-left-string sc) #t)
	   (spell-context-last-word sc))
	  (im-activate-candidate-selector
	   id (spell-get-nr-candidates sc) 0)
	  (spell-context-set-candidate-window! sc #t)
	  ))
    (if (not (spell-has-preedit? sc))
	(begin
	  (spell-context-set-candidate-window! sc #f)
	  (im-deactivate-candidate-selector id)))
    (if (spell-context-candidate-window sc)
	(begin
	  (spell-get-candidates!
	   sc
	   (spell-make-string sc (spell-context-left-string sc) #t)
	   (spell-context-last-word sc))	  
	  (im-select-candidate id (spell-context-nth sc))))
    ))

(define spell-has-preedit?
  (lambda (ac)
    (or
     (> (length (spell-context-left-string ac)) 0)
     (> (length (spell-context-right-string ac)) 0))))

(define spell-proc-input-no-preedit
  (lambda (c key key-state)
    (let* ((sc (context-data c))
	   (id (context-id c))
	   (key-str (charcode->string (to-lower-char key)))
	   (rkc (spell-context-rk-context sc))
	   (res #f)
	   (direct (ja-direct (charcode->string key)))
	   (immediate-commit))
      (and
       (if (spell-cancel-key? key key-state)
	   (begin
	     (spell-flush sc)
	     #f)
	   #t)
       (if (spell-kana-toggle key key-state)
	   (begin 
	     (spell-context-kana-toggle sc)
	     (spell-update-mode id sc)
	     #f)
	   #t)
       (if (spell-backspace-key? key key-state)
	   (if (not (rk-backspace rkc))
	       (begin
		 (im-commit-raw (context-id c))
		 #f)
	       #f)
	   #t)
       (if (control-key-mask key-state)
	   (begin
	     (im-commit-raw id)
	     #f)
	   #t)
       (if (and
	    (shift-key-mask key-state)
	    (alphabet-char? key))
	   (begin
	     (spell-context-set-immediate-commit! sc #f)
	     #t)
	   #t)
       ;; direct key => commit
       (if direct
	   (begin
	     (im-commit id direct)
	     #f)
	   #t)
       (if (symbol? key)
	   (begin
	     (spell-flush sc)
	     (spell-context-set-last-word! sc "")
	     (im-commit-raw (context-id c))
	     #f)
	   #t)
       (spell-proc-input-with-preedit c key key-state))
      #f)))

(define spell-proc-input-with-preedit
  (lambda (c key key-state)
    (let* ((sc (context-data c))
	   (id (context-id c))
	   (rkc (spell-context-rk-context sc))
	   (stat (spell-context-state sc))
	   (res))
      (and
       (if (spell-begin-conv-key? key key-state)
	   (begin
	     (spell-begin-conversion sc id)
	     #f)
	   #t)
       (if (spell-cancel-key? key key-state)
	   (begin
	     (spell-flush sc)
	     #f)
	   #t)
       (if (spell-backspace-key? key key-state)
	   (begin
	     (if (not (rk-backspace rkc))
		 (if (spell-has-preedit? sc)
		     (spell-context-set-left-string!
		      sc (cdr (spell-context-left-string sc)))
		     (begin
		       (im-commit-raw id)
		       (spell-flush sc))))
	     #f)
	   #t)
       ;; delete
       (if (spell-delete-key? key key-state)
	   (begin
	     (if (not (rk-delete rkc))
		 (if (spell-context-right-string sc)
		     (spell-context-set-right-string!
		      sc
		      (cdr (spell-context-right-string sc)))))
	     #f)
	   #t)
       ;;
       (if (spell-commit-key? key key-state)
	   (begin
	     (im-commit id (spell-make-string
			    sc (spell-context-left-string sc) (spell-context-kana-mode sc)))
	     (spell-flush sc)
	     (spell-update-mode id sc)
	     #f)
	   #t)
       ;; left
       (if (spell-go-left-key? key key-state)
	   (begin
	     (if (spell-context-left-string sc)
		 (let ((c (car (spell-context-left-string sc))))
		   (spell-context-set-left-string!
		    sc (cdr (spell-context-left-string sc)))
		   (spell-context-set-right-string! 
		    sc
		    (cons c (spell-context-right-string sc)))))
	     #f)
	   #t)
       ;; right
       (if (spell-go-right-key? key key-state)
	   (begin
	     (if (spell-context-right-string sc)
		 (let ((c (car (spell-context-right-string sc))))
		   (spell-context-set-right-string!
		    sc (cdr (spell-context-right-string sc)))
		   (spell-context-set-left-string!
		    sc
		    (cons c (spell-context-left-string sc)))))
	     #f)
	   #t)
       (if (numeral-char? key)
	   (begin
	     (spell-context-set-nth! sc (- key 49))
	     (im-commit id (spell-get-nth-candidate sc (- key 49)))
	     (spell-commit-candidate sc)
	     (spell-flush sc)
	     (spell-update-mode id sc)
	     #f)
	   #t)
       ;; modifiers (shiftを除く) => ignore
       (if (and (modifier-key-mask key-state) (not (shift-key-mask key-state)))
	   (begin
	     (im-commit-raw id)
	     #f)
	   #t)
       (begin
	 (set! res
	       (rk-push-key!
		rkc
		(charcode->string (to-lower-char key))))
	 (if res
	     (begin
	       (spell-context-set-left-string!
		sc
		(cons res
		      (spell-context-left-string sc)))
	       (spell-context-set-candidate-window! sc #f) ;FIXME:very duty hack
	       (if (and spell-preedit-immididate-commit? (spell-context-immediate-commit sc))
		   (begin 
		     (im-commit id (spell-make-string sc (spell-context-left-string sc) #t))
		     (spell-flush sc)
		     #f)
		   #t)
	       ))))
      #f)))

(define spell-proc-state-converting
  (lambda (c key key-state)
    (let ((sc (context-data c))
	  (id (context-id c))
	  (res ()))
      (and
       (if (spell-next-candidate key key-state)
	   (begin
	     (spell-context-set-nth! sc
				     (+ 1 (spell-context-nth sc)))
	     (if (not (spell-get-current-candidate
		       sc (spell-context-nth sc)))
	     (spell-context-set-nth! sc 0))
	     (spell-context-set-candidate-op-count!
	      sc
	      (+ 1 (spell-context-candidate-op-count sc)))
	     #f)
	   #t)
       (if (spell-prev-candidate key key-state)
	   (begin
	     (if (> (spell-context-nth sc) 0)
		 (spell-context-set-nth! sc (- (spell-context-nth sc) 1))
		 (spell-context-set-nth! sc (- (spell-get-nr-candidates sc) 1)))
	     #f)
	   #t)
       (if (spell-cancel-key? key key-state)
	   (begin
	     (spell-flush sc)
	     #f)
	   #t)
       (if (spell-commit-key? key key-state)
	   (begin
	     (set! res (spell-get-current-candidate sc))
	     (spell-commit-candidate sc)
	     (spell-flush sc)
	     (spell-update-mode id sc)
	     #f)
	   #t)
       (begin
	 (spell-update-mode id sc)
	 (set! res (spell-get-current-candidate sc))
	 (spell-commit-candidate sc)
	 (spell-flush sc)
	 (let ((res2 (spell-proc-input-no-preedit c key key-state)))
	   (set!
	    res
	    (string-append
	     res 
	     (spell-make-string sc
				(spell-context-tail sc)
				(spell-context-kana-mode sc))))
	   (if (string? res2)
	       (set! res
		     (string-append res res2))))))
      res)))

(define spell-proc-mode-latin
  (lambda (c key key-state)
    (let ((sc (context-data c))
	  (id (context-id c)))
      (if
       (spell-on-key? key key-state)
       (begin
	 (spell-context-set-mode! sc 1)
	 (spell-update-mode id sc))
       (im-commit-raw id))
      ())))

(define spell-push-key
  (lambda (c key key-state)
    (let* ((sc (context-data c))
	   (state (spell-context-state sc))
	   (mode (spell-context-mode sc))
	   (fun)
	   (res))
	    (if (spell-has-preedit? sc)
		(set! fun spell-proc-input-with-preedit)
		(set! fun spell-proc-input-no-preedit))
	    (if (= state 'spell-state-converting)
		(set! fun spell-proc-state-converting))))
      (set! res (fun c key key-state))  
      (if res
	  (im-commit (context-id c) res))
      (spell-update-preedit (context-id c) sc)
      (spell-update-candidate-window sc (context-id c))
      )

(define spell-init-handler
  (lambda (id arg)
    ()))

(define spell-press-key-handler
  (lambda (id key state)
    (let* ((c (find-context id)))
      (spell-push-key c key state))))

(define spell-release-key-handler
  (lambda (id key state)
    ()))

(define spell-reset-handler
  (lambda (id)
    ()))

(define spell-mode-handler
  (lambda (id mode)
    (let* ((c (find-context id))
	   (sc (context-data c)))
      (spell-flush sc)
      (spell-context-set-mode! sc mode)
      (if (= mode 1)
	  (spell-context-set-kana-mode! sc #t))
      (if (= mode 2)
	  (spell-context-set-kana-mode! sc #f))
      (spell-update-preedit id sc)
      ())))

(define spell-get-candidate-handler
  (lambda (id idx)
    (let* ((c (find-context id))
	   (sc (context-data c)))
      (spell-get-nth-candidate sc idx))))

(define spell-set-candidate-index-handler
  (lambda (id idx)
    (let* ((c (find-context id))
	   (sc (context-data c)))
      (spell-context-set-nth! sc idx)
      (spell-update-preedit  id sc))))

(register-im
 'spell
 "ja"
 "EUC-JP"
 #f
 spell-init-handler
 #f
 spell-mode-handler
 spell-press-key-handler
 spell-release-key-handler
 spell-reset-handler
 spell-get-candidate-handler
 spell-set-candidate-index-handler
 #f)
