;;; egg.el --- EGG Input Method Architecture

;; Copyright (C) 1997, 1998 Mule Project, Powered by Electrotechnical
;; Laboratory, JAPAN.
;; Project Leader: Satoru Tomura <tomura@etl.go.jp>

;; Author: NIIBE Yutaka <gniibe@mri.co.jp>
;;         KATAYAMA Yoshio <kate@pfu.co.jp>
;; Maintainer: NIIBE Yutaka <gniibe@mri.co.jp>
;; Keywords: mule, multilingual, input method

;; This file is part of EGG.

;; EGG is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; EGG is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;;; Code:
(require 'egg-edep)

(defvar egg-mode-preference t
  "Non-nil if modefull.")

(defvar egg-default-language)
(defvar egg-last-method-name)
(make-variable-buffer-local 'egg-last-method-name)

;;;###autoload
(defun egg-mode (&rest arg)
  "Toggle EGG  mode.
\\[describe-bindings]
"
  (interactive "P")
  (if (null arg)
      ;; Turn off
      (progn
	(cond
	 ((its-in-fence-p)
	  (its-exit-mode))
	 ((egg-get-bunsetsu-info (point))
	  (egg-exit-conversion)))
	(setq describe-current-input-method-function nil)
	(setq current-input-method nil)
	(use-local-map (keymap-parent (current-local-map)))
	(remove-hook 'input-method-activate-hook 'its-set-mode-line-title t)
	(force-mode-line-update))
    ;; Turn on
    (if (null (string= (car arg) egg-last-method-name))
	(progn
	  (funcall (nth 1 arg))
	  (setq egg-default-language its-current-language)))
    (setq egg-last-method-name (car arg))
    (use-local-map (if egg-mode-preference
		       (egg-modefull-map)
		     (egg-modeless-map)))
    (setq inactivate-current-input-method-function 'egg-mode)
    (setq describe-current-input-method-function 'egg-help)
    (make-local-hook 'input-method-activate-hook)
    (add-hook 'input-method-activate-hook 'its-set-mode-line-title nil t)))

(defun egg-modefull-map ()
  "Generate modefull keymap for EGG mode."  
  (let ((map (make-sparse-keymap))
	(i 33))
    ;; BAD BAD BAD it should be UNDO
    ;;    (define-key map "\C-_" 'egg-jis-code-input)
    (while (< i 127)
      (define-key map (vector i) 'egg-self-insert-char)
      (setq i (1+ i)))
    (its-define-select-keys map)
    (set-keymap-parent map (current-local-map))
    map))

(defun egg-modeless-map ()
  "Generate modeless keymap for EGG mode."
  (let ((map (make-sparse-keymap)))
    (define-key map " " 'mlh-space-bar-backward-henkan)
    (define-key map "\C-_" 'egg-jis-code-input)
    (set-keymap-parent map (current-local-map))
    map))

(defun egg-self-insert-char ()
  (interactive)
  (its-start last-command-char))

(defvar egg-mark-list nil)
(defvar egg-suppress-marking nil)

(defun egg-set-face (beg eng face &optional object)
  (put face 'face face)
  (add-text-properties beg eng
		       (list 'category face
			     'egg-face t
			     'modification-hooks '(egg-mark-modification))
		       object))

(defun egg-mark-modification (beg end)
  (if (and (null egg-suppress-marking)
	   (or (get-text-property beg 'egg-face)
	       (setq beg (next-single-property-change beg 'egg-face)))
	   (or (get-text-property (1- end) 'egg-face)
	       (setq end (previous-single-property-change end 'egg-face)))
	   (< beg end))
      (let ((list egg-mark-list)
	    (found 0)
	    pair mb me b e)
	(add-hook 'post-command-hook 'egg-redraw-face t)
	(setq list egg-mark-list)
	(while (and list (< found 2))
	  (setq pair (car list)
		list (cdr list)
		mb (car pair)
		me (cdr pair)
		b (marker-position mb)
		e (marker-position me))
	  (cond
	   ;; no overwrapping -- SKIP
	   ((or (null (eq (marker-buffer mb) (current-buffer)))
		(or (> beg e) (< end b))))
	   ;; completely included
	   ((and (>= beg b) (<= end e))
	    (setq found 3))
	   ;; partially overwrapping
	   (t
	    (set-marker mb nil)
	    (set-marker me nil)
	    (setq egg-mark-list (delete pair egg-mark-list)
		  beg (min beg b)
		  end (max end e)
		  found (1+ found)))))
	(if (< found 3)
	    (progn
	      (setq b (make-marker)
		    e (make-marker)
		    egg-mark-list (cons (cons b e) egg-mark-list))
	      (set-marker b beg)
	      (set-marker e end))))))

(defun egg-redraw-face ()
  (let ((inhibit-read-only t)
	(inhibit-point-motion-hooks t)
	(egg-suppress-marking t)
	(list egg-mark-list)
	(org-buffer (current-buffer))
	(org-point (point))
	mb me b e p)
    (setq egg-mark-list nil)
    (remove-hook 'post-command-hook 'egg-redraw-face)
    (while list
      (setq mb (car (car list))
	    me (cdr (car list))
	    list (cdr list))
      (when (marker-buffer mb)
	(set-buffer (marker-buffer mb))
	(let ((before-change-functions nil) (after-change-functions nil))
	  (save-restriction
	    (widen)
	    (setq b (max mb (point-min))
		  e (min me (point-max)))
	    (set-marker mb nil)
	    (set-marker me nil)
	    (while (< b e)
	      (if (null (get-text-property b 'egg-face))
		  (setq b (next-single-property-change b 'egg-face nil e)))
	      (setq p (next-single-property-change b 'egg-face nil e))
	      (when (< b p)
		(goto-char b)
		(setq str (buffer-substring b p))
		(delete-region b p)
		(remove-text-properties 0 (- p b) '(face) str)
		(insert str)
		(setq b p)))))))
    (set-buffer org-buffer)
    (goto-char org-point)))

(defun egg-hinshi-select ()
 (menudiag-select ; Should generate at initialization time
  '(menu  "品詞名:"
	  (("普通名詞" .
	    (menu  "品詞名[普通名詞]:"
		   ("名詞" "サ行(する)&名詞" "一段&名詞"
		    "形容動詞&名詞" "数詞")))
	   ("固有名詞" .
	    (menu  "品詞名[固有名詞]:"
		   ("人名" "地名" "人名&地名" "固有名詞")))
	   ("動詞" .
	    (menu  "品詞名[動詞]:"
		   ("一段" "一段&名詞" "カ行五段" "ガ行五段"
		    "サ行五段" "タ行五段")))
	   ("特殊な動詞" .
	    (menu  "品詞名[特殊な動詞]:"
		   ("カ行(行く)" "ラ行(下さい)" "来(こ)"
		    "来(き)" "来(く)" "為(し)")))
	   ("動詞以外の用言" .
	    (menu  "品詞名[動詞以外の用言]:"
		   ("形容詞" "形容動詞" "形容動詞&名詞"
		    "形容動詞(たる)")))))))

;; XXX: Should use backend interface
(defun egg-toroku-region (start end)
  (interactive "r")
  (let* ((env (wnn-get-environment wnn-dictionary-specification)) ; XXX
	 (kanji (buffer-substring start end))
	 (yomi (read-multilingual-string 
		(format "辞書登録『%s』  読み:" kanji)))
	 (dic (menudiag-select (list 'menu "登録辞書名:"
				 ;; XXX
				 (wnn-list-writable-dictionaries-byname env))))
	 (dic-name (wnn-dict-name dic))
	 (hinshi (egg-hinshi-select))
	 (hinshi-id (wnn-hinshi-number env hinshi)))
    (if (y-or-n-p
	 (format "辞書項目『%s』(%s: %s)を %s に登録します"
		 kanji yomi hinshi dic-name))
	(let ((r (wnn-add-word env dic yomi kanji "" hinshi-id 0)))
	  (if (< r 0)
	    (error "辞書登録『%s』(%s: %s) %s に失敗しました: %s"
		   kanji yomi hinshi dic-name
		   (wnnrpc-get-error-message (- r)))
	    (message 
	     "辞書項目『%s』(%s: %s)を %s に登録しました" 
	     kanji yomi hinshi dic-name))))))

;;;
;;; auto fill controll
;;;

(defun egg-do-auto-fill ()
  (if (and auto-fill-function (> (current-column) fill-column))
      (let ((ocolumn (current-column)))
	(funcall auto-fill-function)
	(while (and (< fill-column (current-column))
		    (< (current-column) ocolumn))
  	  (setq ocolumn (current-column))
	  (funcall auto-fill-function)))))

(require 'its)
(require 'menudiag)
(require 'egg-mlh)
(require 'egg-cnv)
(require 'egg-com)
(require 'custom)			; Really?

(defgroup egg nil
  "Tamagotchy --- EGG Versio 4.0")

(add-hook 'kill-emacs-hook 'egg-kill-emacs-function)
(defun egg-kill-emacs-function ()
  (egg-finalize-backend))

(provide 'egg)

;;; egg.el ends here