;;;
;;; 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.
;;;;

;;
; following functions are implemented within C
;  rk-lib-find-seq
;  rk-lib-find-partial-seq
;  rk-lib-expect-seq
;
; back match is mainly used for Hangul


;(rule seq immediate-flag back)
(define rk-context-new
  (lambda (rule immediate-commit back)
    (let ((res (copy-list '(() () () ()))))
      (rk-context-set-rule! res rule)
      (rk-context-set-immediate-commit! res
					immediate-commit)
      (rk-context-set-back-match! res back)
      res)))

;; accessor
(define rk-context-rule
  (lambda (rkc)
    (car (nthcdr 0 rkc))))
(define rk-context-set-rule!
  (lambda (rkc rule)
    (set-car! (nthcdr 0 rkc) rule)))

(define rk-context-seq
  (lambda (rkc)
    (car (nthcdr 1 rkc))))
(define rk-context-set-seq!
  (lambda (rkc seq)
    (set-car! (nthcdr 1 rkc) seq)))

(define rk-context-immediate-commit
  (lambda (rkc)
    (car (nthcdr 2 rkc))))
(define rk-context-set-immediate-commit!
  (lambda (rkc flag)
    (set-car! (nthcdr 2 rkc) flag)))

(define rk-context-back-match
  (lambda (rkc)
    (car (nthcdr 3 rkc))))
(define rk-context-set-back-match!
  (lambda (rkc flag)
    (set-car! (nthcdr 3 rkc) flag)))

;; back match
(define rk-find-longest-back-match
  (lambda (rule seq)
    (if seq
	(if (rk-lib-find-seq seq rule)
	    seq
	    (rk-find-longest-back-match rule (cdr seq)))
	#f)))
;; back match
(define rk-find-longest-head
  (lambda (rseq rule)
    (let ((seq (reverse rseq)))
      (if (rk-lib-find-seq seq rule)
	  seq
	  (if rseq
	      (rk-find-longest-head (cdr rseq) rule)
	      #f)))))
;; back match
(define rk-check-back-commit
  (lambda (rkc rule rseq)
    (let* ((seq (reverse rseq))
	   (len (length seq))
	   (longest-tail (rk-find-longest-back-match rule seq))
	   (longest-head (reverse (rk-find-longest-head rseq rule)))
	   (head
	    (truncate-list seq
			   (- (length seq) (length longest-tail))))
	   (partial (rk-lib-find-partial-seq seq rule))
	   (tail-partial
	    (if longest-tail
		(rk-lib-find-partial-seq longest-tail rule)
		#f))
	   (c (rk-lib-find-seq longest-tail rule))
	   (t (rk-lib-find-seq seq rule))
	   (res ()))
      (and
       (if (> len 0)
	   #t
	   #f)
       (if partial
	   #f
	   #t)
       (if (and c t)
	   #f
	   #t)
       (if (not tail-partial)
	   (begin
	     (set! res (cadr (rk-lib-find-seq (reverse longest-head) rule)))
	     (rk-context-set-seq!
	      rkc
	      (reverse
	       (truncate-list (reverse seq)
			      (- (length seq)
				 (length longest-head)))))
	     #f)
	   #t)
       (begin
	 (set! res (cadr (rk-lib-find-seq head rule)))
	 (rk-context-set-seq! rkc (reverse longest-tail))))
      res)))
;;
(define rk-partial-seq?
  (lambda (rkc s)
    (rk-lib-find-partial-seq
     (reverse s) (rk-context-rule rkc))))
;; API
(define rk-partial?
  (lambda (rkc)
    (if (rk-context-back-match rkc)
	#t
	(rk-partial-seq?
	 rkc
	 (rk-context-seq rkc)))))

;; API
(define rk-current-seq
  (lambda (rkc)
    (let* ((s (rk-context-seq rkc))
	   (rule (rk-context-rule rkc)))
      (rk-lib-find-seq (reverse s) rule))))

;; API
(define rk-flush
  (lambda (context)
    (rk-context-set-seq! context ())))

;; API
(define rk-backspace
  (lambda (context)
    (if
     (> (length (rk-context-seq context)) 0)
     (begin
       (rk-context-set-seq! context
		 (cdr (rk-context-seq context)))
       #t)
     #f)))
 
;; API
(define rk-delete
  (lambda (context)
    (if
     (> (length (rk-context-seq context)) 0)
     (begin
       (rk-context-set-seq! context
		 (cdr (rk-context-seq context)))
       #t)
     #f)))

;; front match
(define rk-proc-tail
  (lambda (context seq)
    (let* ((rule (rk-context-rule context))
	   (old-seq
	    (rk-lib-find-seq
	     (reverse (rk-context-seq context)) rule))
	   (res #f))
      (if old-seq
	  (begin
	    (rk-flush context)
	    (rk-push-key! context (car seq))
	    (set! res (cadr old-seq)))
	  (if (rk-context-seq context)
	      (begin
		(rk-flush context)
		(set! res
		      (rk-push-key! context (car seq))))))
      res)))


(define rk-proc-end-seq
  (lambda (context seq s)
    (if (rk-context-immediate-commit context)
	(begin
	  (rk-context-set-seq! context (cdar seq))
	  (cadr seq))
	(begin
	  (rk-context-set-seq! context s)
	  #f))))
;; API
(define rk-expect
  (lambda (rkc)
    (let
	((s (reverse (rk-context-seq rkc)))
	 (rule (rk-context-rule rkc)))
      (rk-lib-expect-seq s rule))))

;; back match
(define rk-push-key-back-match
  (lambda (rkc key)
    (let*
	((cur-seq (rk-context-seq rkc))
	 (new-seq (cons key cur-seq))
	 (rule (rk-context-rule rkc))
	 (res))
      (rk-context-set-seq! rkc new-seq)
      (rk-check-back-commit rkc rule new-seq))))

;; front match
(define rk-push-key-front-match
  (lambda (rkc key)
    (let*
	((s (rk-context-seq rkc))
	 (s (cons key s))
	 (rule (rk-context-rule rkc))
	 (seq (rk-lib-find-seq (reverse s) rule))
	 (res))
      (set!
       res
       (if (rk-partial-seq? rkc s)
	   (begin
	     (rk-context-set-seq! rkc s)
	     #f)
	   (if seq
	       (rk-proc-end-seq rkc seq s)
	       (rk-proc-tail rkc s))))
      res)))


;;超適当。rk.scmを理解するか、あとでごっそり設計しなおす事。
(define rk-push-key-last!
  (lambda (rkc)
    (let*
	((s (rk-context-seq rkc))
	 (rule (rk-context-rule rkc))
	 (seq (rk-lib-find-seq (reverse s) rule)))
      (rk-proc-end-seq rkc seq s)
      )))


(define rk-push-key!
  (lambda (rkc key)
    (if (rk-context-back-match rkc)
	(rk-push-key-back-match rkc key)
	(rk-push-key-front-match rkc key))))
;;
(define rk-pending
  (lambda (c)
    (string-list-concat
     (rk-context-seq c))))
