;;; util.scm: Utility functions for uim.
;;;
;;; 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.
;;;;

;;
(define control-char?
  (lambda (c)
    (and (integer? c)
	 (or (< c 32)
	     (= c 127)))))
;;
(define alphabet-char?
  (lambda (c)
    (and (integer? c)
	 (or
	  (and (>= c 65) (<= c 90))
	  (and (>= c 97) (<= c 122))))))
;;
(define usual-char?
  (lambda (c)
    (and (integer? c)
	 (and (> c 32) (< c 127)))))
;;
(define numeral-char?
  (lambda (c)
    (and (integer? c)
	  (and (>= c 48)
	       (<= c 57)))))

;;
(define numeral-char->number
  (lambda (c)
    (if (numeral-char? c)
	(- c 48)
	c)))
;;
(define to-lower-char
  (lambda (c)
    (if (and (alphabet-char? c) (< c 91))
	(+ c 32)
	c)))
;;
(define string-list-concat
  (lambda (lst)
    (let ((len (length lst)))
      (if (= len 0)
	  ""
	  (string-append
	   (string-list-concat (cdr lst))
	   (car lst))))))
;;
(define string-find
  (lambda (lst str)
    (if (null? lst)
	#f
	(if (string=? (car lst) str)
	    #t
	    (string-find (cdr lst) str)))))
;;
(define truncate-list
  (lambda (lst len)
    (if (< (length lst) len)
	#f
	(if (= len 0)
	    '()
	    (cons (car lst)
		  (truncate-list
		   (cdr lst)
		   (- len 1)))))))

;; procedural 'or' for use with 'apply'
;; e.g. (apply proc-or boolean-lst)
;; should be deprecated and replaced with a proper, Schemer's way
(define proc-or
  (lambda xs
    (if (null? xs)
	#f
	(or (car xs)
	    (apply proc-or (cdr xs))))))

;; procedural 'and' for use with 'apply'
;; e.g. (apply proc-and boolean-lst)
;; should be deprecated and replaced with a proper, Schemer's way
(define proc-and
  (lambda xs
    (if (null? xs)
	#t
	(and (car xs)
	     (apply proc-and (cdr xs))))))

;;
;; R5RS procedures (don't expect 100% compatibility)
;;
(define else #t)

(define boolean?
  (lambda (x)
    (or (eq? x #t)
        (eq? x #f))))

(define integer?
  (lambda (x)
    (number? x)))

(define list?
  (lambda (x)
    (or (null? x)
	(and (pair? x)
	     (list? (cdr x))))))

(define string->symbol intern)

;; accepts up to 2 lists
(define map mapcar)

;; accepts up to 2 lists
;; process order is guaranteed by siod's mapcar implementation
(define for-each mapcar)

;;
;; SRFI procedures (don't expect 100% compatibility)
;;

;(define fold)

;; accepts single list only
(define filter-map
  (lambda (f lst)
    (let self ((f f)
	       (lst lst)
	       (res ()))
      (if (null? lst)
	  (reverse res)
	  (let ((mapped (apply f (list (car lst)))))
	    (self f (cdr lst) (if mapped
				  (cons mapped res)
				  res)))))))

;; for eval
(define toplevel-env ())

;; used for dynamic environment substitution of closure
(define enclose-another-env
  (lambda (closure another-env)
    (let* ((code (%%closure-code closure))
	   (args (car code))
	   (body (cdr code))
	   (definition (list 'lambda args body)))
      (eval definition another-env))))

(define define-record
  (lambda (rec-sym rec-spec)
    (let ((i 0))
      (for-each (lambda (spec)
		  (let* ((index i)
			 (elem-sym (nth 0 spec))
			 (default  (nth 1 spec))
			 (getter-sym (symbolconc rec-sym '- elem-sym))
			 (getter (lambda (rec)
				   (nth index rec)))
			 (setter-sym (symbolconc rec-sym '-set- elem-sym '!))
			 (setter (lambda (rec val)
				   (set-car!
				    (nthcdr index rec)
				    val))))
		    (eval (list 'define getter-sym getter)
			  toplevel-env)
		    (eval (list 'define setter-sym setter)
			  toplevel-env)
		    (set! i (+ i 1))))
		rec-spec))
    (let ((creator-sym (symbolconc rec-sym '-new))
	  (creator (lambda init-lst
		     (let ((defaults (map cadr rec-spec)))
		       (cond
			((null? init-lst)
			 defaults)
			((= (length defaults)
			    (length init-lst))
			 (copy-list init-lst))
			(else
			 #f))))))
      (eval (list 'define creator-sym creator)
	    toplevel-env))))

;; for direct candidate selection
(define number->candidate-index
  (lambda (n)
    (cond
     ((= n 0)
      9)
     ((and (>= n 1)
	   (<= n 9))
      (- n 1))
     (else
      n))))

;; update style-element vars
;; style-spec requires list of (style-element-name . validator)
(define update-style
  (lambda (style-spec style)
    (let* ((elem (car style))
	   (name (car elem))
	   (val (if (symbol? (cdr elem))
		    (symbol-value (cdr elem))
		    (cdr elem)))
	   (spec (assq name style-spec))
	   (valid? (symbol-value (cdr spec))))
      (if (valid? val)
	  (set-symbol-value! name val))
      (if (not (null? (cdr style)))
	  (update-style style-spec (cdr style))))))

;;
;; Preedit color related configurations and functions.
;;
(define reversed-preedit-foreground #f)
(define reversed-preedit-background #f)
(define separator-foreground #f)
(define separator-background #f)
(define reversed-separator-foreground #f)
(define reversed-separator-background #f)

(define uim-color 'uim-color-uim)
(define uim-color-spec
  '((reversed-preedit-foreground   . string?)
    (reversed-preedit-background   . string?)
    (separator-foreground          . string?)
    (separator-background          . string?)
    (reversed-separator-foreground . string?)
    (reversed-separator-background . string?)))

;; predefined color styles
(define uim-color-uim
  '((reversed-preedit-foreground   . "white")
    (reversed-preedit-background   . "black")
    (separator-foreground          . "lightsteelblue")
    (separator-background          . "")
    (reversed-separator-foreground . "white")
    (reversed-separator-background . "black")))
(define uim-color-atok
  '((reversed-preedit-foreground   . "black")
    (reversed-preedit-background   . "blue")
    (separator-foreground          . "lightsteelblue")
    (separator-background          . "")
    (reversed-separator-foreground . "black")
    (reversed-separator-background . "blue")))

;; functions for multiple segments input method. used to unify
;; common features of multi-segment IMs such as Canna and Anthy
(define multi-segment-type-hiragana 0)
(define multi-segment-type-katakana 1)
(define multi-segment-type-hankana 2)

(define multi-segment-mode-direct 0)
(define multi-segment-mode-hiragana 1)
(define multi-segment-mode-katakana 2)
(define multi-segment-mode-wide-latin 3)
(define multi-segment-mode-hankana 4)

(define multi-segment-make-index-list
  (lambda (n old-lst)
    (if (< n (length old-lst))
	(truncate-list old-lst n 1)
	(append old-lst
		(multi-segment-make-index-list-rec (- n
					(length old-lst)))))))
(define multi-segment-make-index-list-rec
  (lambda (n)
    (if (> n 0)
	(cons 0
	      (multi-segment-make-index-list-rec (- n 1)))
	'())))

(define multi-segment-make-string
  (lambda (sl dir type)
    (let ((get-str-by-type
	   (lambda (l)
	     (cond
	      ((= type multi-segment-type-hiragana)
	       (caar l))
	      ((= type multi-segment-type-katakana)
	       (car (cdar l)))
	      ((= type multi-segment-type-hankana)
	       (cadr (cdar l)))))))
      (if (not (null? sl))
	  (if dir
	      (string-append (multi-segment-make-string (cdr sl) dir type)
			     (get-str-by-type sl))
	      (string-append (get-str-by-type sl)
			     (multi-segment-make-string (cdr sl) dir type)))
	  ""))))

(define multi-segment-make-left-string
  (lambda (sl kana)
    (multi-segment-make-string sl #t kana)))

(define multi-segment-make-right-string
  (lambda (sl kana)
    (multi-segment-make-string sl #f kana)))

(define multi-segment-opposite-kana
  (lambda (kana)
    (cond
     ((= kana multi-segment-type-hiragana)
      multi-segment-type-katakana)
     ((= kana multi-segment-type-katakana)
      multi-segment-type-hiragana)
     ((= kana multi-segment-type-hankana)
      multi-segment-type-hiragana))))


(define candidate-window-position "caret")
