;;; iiimcf-sc.el --- IIIMCF server control input method.
;;; 

;; Copyright (C) 2000 MIYASHITA Hisashi

;; Author: MIYASHITA Hisashi <himi@m17n.org>

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

;; This program 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:
;; This module provides a simple input method
;; under the server-side control via IIIM.

;;; Code:

(require 'iiimcf)

;;; version.

(defconst iiimcf-server-control-version "0.3 (Yodo)")

;;; Customizable options.

(defgroup iiimcf-server-control nil
  "*IIIMCF server control input method."
  :tag "IIIMCF Server Control Input Method"
  :group 'applications
  :group 'i18n)

(defcustom iiimcf-server-control-default-port 9010
  "*Default port number for IIIM server."
  :tag "Default port for IIIMCF Server Control"
  :group 'iiimcf-server-control :type 'integer)

(defcustom iiimcf-server-control-hostlist '("localhost")
  "*A list of IIIM Server hosts.
If each hostname has the form of \"HOSTNAME:N\", use N-th port."
  :tag "Hostlist for IIIMCF Server Control"
  :group 'iiimcf-server-control :type '(repeat string))

(defcustom iiimcf-server-control-username
  (concat (user-login-name) "@" (system-name))
  "*Username passed to IIIM server."
  :tag "Username for IIIMCF Server Control"
  :group 'iiimcf-server-control :type 'string)

(defcustom iiimcf-server-control-default-language nil
  "*Use this language by default.
If nil, use the first candidate sent by a server."
  :tag "Default language for IIIMCF Server Control"
  :group 'iiimcf-server-control :type 'string)

(defcustom iiimcf-server-control-default-input-method nil
  "*Use this input method by default.
If nil, don't apply input method preference to a server."
  :tag "Default input method for IIIMCF Server Control"
  :group 'iiimcf-server-control :type 'string)

(defcustom iiimcf-server-control-async-invocation-p t
  "*Receives and responds incomming messages asynchronously, if non-nil."
  :tag "Aaync invocation flag for IIIMCF Server Control"
  :group 'iiimcf-server-control :type 'boolean)

;;; preedit text

(defcustom iiimcf-server-control-preedit-open-string "|"
  "*Put this string before preedit string."
  :tag "Preedit open string for IIIMCF Server Control"
  :group 'iiimcf-server-control :type 'string)

(defcustom iiimcf-server-control-preedit-close-string "|"
  "*Put this string after preedit string."
  :tag "Preedit close string for IIIMCF Server Control"
  :group 'iiimcf-server-control :type 'string)

(defface iiimcf-server-control-preedit-reverse-face
  '((((class color)
      (background dark))
     (:foreground "black" :background "DarkSlateGray1"))
    (((class color)
      (background light))
     (:foreground "black" :background "DarkSlateGray3"))
    (t (:inverse-video t)))
  "Face used for preedit reverse attribute"
  :group 'iiimcf-server-control)

(defface iiimcf-server-control-preedit-underline-face
  '((t (:underline t)))
  "Face used for preedit underline attribute"
  :group 'iiimcf-server-control)

(defface iiimcf-server-control-preedit-highlight-face
  '((((class color)
      (background dark))
     (:bold t :foreground "black" :background "SeaGreen1"))
    (((class color)
      (background light))
     (:bold t :foreground "black" :background "SeaGreen3"))
    (t (:bold t)))
  "Face used for preedit highlight attribute"
  :group 'iiimcf-server-control)

(defface iiimcf-server-control-preedit-warning-face
  '((t (:bold t :foreground "yellow" :background "red")))
  "Face used for warning for users"
  :group 'iiimcf-server-control)

(defcustom iiimcf-server-control-preedit-face-alist
  '((reverse iiimcf-server-control-preedit-reverse-face
	     ("[" . "]"))
    (underline iiimcf-server-control-preedit-underline-face
	       ("_" . "_"))
    (highlight iiimcf-server-control-preedit-highlight-face
	       ("+" . "+"))
    (unknown-ucs iiimcf-server-control-preedit-warning-face
		 ("X" . "X")))
  "*A-list used for decorating preedit text."
  :tag "Preedit decoration settings for IIIMCF Server Control"
  :group 'iiimcf-server-control
  :type '(list (list :tag "Used for REVERSE text."
		     (const reverse) face (cons string string))
	       (list :tag "Used for UNDERLINE text."
		     (const underline) face (cons string string))
	       (list :tag "Used for HIGHLIGHT text."
		     (const highlight) face (cons string string))))

(defcustom iiimcf-server-control-preedit-use-face-p
  (if window-system t nil)
  "*Use faces when drawing preedit text, if non-nil."
  :tag "Flag whether faces are used for drawing preedit text."
  :group 'iiimcf-server-control :type 'boolean)

;;; internal variables

(defvar iiimcf-server-control-enable nil)
(make-variable-buffer-local 'iiimcf-server-control-enable)
(put 'iiimcf-server-control-enable 'permanent-local t)
(defvar iiimcf-server-control-preedit-mode nil)
(make-variable-buffer-local 'iiimcf-server-control-preedit-mode)
(put 'iiimcf-server-control-preedit-mode 'permanent-local t)

(defvar iiimcf-server-control-com-id nil)
(defvar iiimcf-server-control-im-id nil)
(defvar iiimcf-server-control-ic-id nil)
(defvar iiimcf-server-control-dynamic-event-flow-p nil)
(defvar iiimcf-server-control-editing-buffer nil
  "The buffer where a user is inputting currently.")
(defvar iiimcf-server-control-preedit "")
(defvar iiimcf-server-control-preedit-marker (make-marker))
;; (defvar iiimcf-server-control-caret-overlay
;;   (make-overlay 0 0))
;; (overlay-put iiimcf-server-control-caret-overlay
;;	     'face 'modeline)
(defvar iiimcf-server-control-maintaining-preedit-text nil)

(defvar iiimcf-server-control-mode-line "")
(make-variable-buffer-local 'iiimcf-server-control-mode-line)
(if (null (memq 'iiimcf-server-control-mode-line mode-line-format))
    (let ((ll mode-line-format)
	  gen elem)
      (setq-default
       mode-line-format
       (catch 'tag
	 (while (setq elem (car ll))
	   (if (or (memq elem '(mode-line-mule-info
				modeline-multibyte-status))
		   (equal elem "-%-"))
	       (throw 'tag (nconc (nreverse gen)
				  (list 'iiimcf-server-control-mode-line)
				  ll)))
	   (setq gen (cons elem gen)
		 ll (cdr ll)))))))

;;; lookup choice
(defvar iiimcf-server-control-current-lookup-choice nil)
(defvar iiimcf-server-control-lookup-choice-configuration nil)

;;; private database

(defvar iiimcf-server-control-com-id-plists nil)

(defun iiimcf-server-control-register-com-id (com-id)
  (if (null (assq com-id iiimcf-server-control-com-id-plists))
      (setq iiimcf-server-control-com-id-plists
	    (cons (list com-id)
		  iiimcf-server-control-com-id-plists))))

(defun iiimcf-server-control-unregister-com-id (com-id)
  (let ((slot (assq com-id iiimcf-server-control-com-id-plists)))
    (if slot
	(setq iiimcf-server-control-com-id-plists
	      (delq slot
		    iiimcf-server-control-com-id-plists)))))

(defsubst iiimcf-server-control-com-id-get (com-id prop)
  (plist-get (cdr (assq com-id iiimcf-server-control-com-id-plists))
	     prop))

(defsubst iiimcf-server-control-com-id-put (com-id prop val)
  (let ((slot (assq com-id iiimcf-server-control-com-id-plists)))
    (if slot
	(setcdr slot (plist-put (cdr slot) prop val)))))

;;; keymap

;; keymap for initial state.
(defvar iiimcf-server-control-initial-state-keymap
  (let ((map (make-keymap))
	(i 32))
    (while (< i 127)
      (define-key map (char-to-string i)
	'iiimcf-server-control-keyforward)
      (setq i (1+ i)))
    ;; For our own features.
    (define-key map "\C-c\C-\\\C-l" 'iiimcf-server-control-change-language)
    (define-key map "\C-c\C-\\\C-i" 'iiimcf-server-control-change-input-method)
    (define-key map "\C-c\C-\\\C-s" 'iiimcf-server-control-change-iiim-server)
    map))

;; keymap for preedit state
(defvar iiimcf-server-control-preedit-state-keymap
  (let ((map (make-keymap))
	(i 0))
    (while (<= i 127)
      (if (/= i ?\x1B) ; skip ESC
	  (define-key map (char-to-string i)
	    'iiimcf-server-control-keyforward))
      (setq i (1+ i)))
    (setq i 128)
    (while (< i 256)
      (define-key map (vector i)
	'iiimcf-server-control-keyforward)
      (setq i (1+ i)))
    (define-key map [delete] 'iiimcf-server-control-keyforward)
    (define-key map [backspace] 'iiimcf-server-control-keyforward)
    (define-key map [return] 'iiimcf-server-control-keyforward)
    (define-key map [up] 'iiimcf-server-control-keyforward)
    (define-key map [down] 'iiimcf-server-control-keyforward)
    (define-key map [left] 'iiimcf-server-control-keyforward)
    (define-key map [right] 'iiimcf-server-control-keyforward)
    (define-key map [(shift up)] 'iiimcf-server-control-keyforward)
    (define-key map [(shift down)] 'iiimcf-server-control-keyforward)
    (define-key map [(shift left)] 'iiimcf-server-control-keyforward)
    (define-key map [(shift right)] 'iiimcf-server-control-keyforward)
    (define-key map [(control up)] 'iiimcf-server-control-keyforward)
    (define-key map [(control down)] 'iiimcf-server-control-keyforward)
    (define-key map [(control left)] 'iiimcf-server-control-keyforward)
    (define-key map [(control right)] 'iiimcf-server-control-keyforward)
    (set-keymap-parent map iiimcf-server-control-initial-state-keymap)
    map)
  "Keymap used for forwarding keyevents to IIIM server side in preedit state.")

;;; IIIMCF event handler.

(defconst iiimcf-server-control-com-level-handler-alist
  '((iiimcf-server-control-setup-event-flow-mode . iiimp-im-register-trigger-keys)
    (iiimcf-server-control-maintain-language-list . iiimp-im-connect-reply)
    (iiimcf-server-control-maintain-input-method-list . iiimp-im-setimvalues)))

(defconst iiimcf-server-control-ic-level-handler-alist
  '((iiimcf-server-control-trigger-notify . iiimp-im-trigger-notify)
    (iiimcf-server-control-maintain-preedit-text . iiimp-im-preedit-draw)
    (iiimcf-server-control-commit-string . iiimp-im-commit-string)
    (iiimcf-server-control-forward-event . iiimp-im-forward-event)
    (iiimcf-server-control-forward-event . iiimp-im-forward-event-with-operations)
    (iiimcf-server-control-prepare-lookup-choice . iiimp-im-lookup-choice-start)
    (iiimcf-server-control-draw-lookup-choice . iiimp-im-lookup-choice-draw)
    (iiimcf-server-control-redraw-lookup-choice . iiimp-im-lookup-choice-process)
    (iiimcf-server-control-clear-lookup-choice . iiimp-im-lookup-choice-done)
    (iiimcf-server-control-draw-status . iiimp-im-status-draw)
    (iiimcf-server-control-draw-aux-data . iiimp-im-aux-draw)))

(defun iiimcf-server-control-register-handlers
  (alist com-id &optional im-id ic-id)
  (let (elem)
    (while (setq elem (car alist))
      (iiimcf-register-handler
       (car elem)
       (if (and im-id ic-id)
	   (list (cdr elem) com-id im-id ic-id)
	 (list (cdr elem) com-id)))
      (setq alist (cdr alist)))))

(defun iiimcf-server-control-remove-handlers (alist)
  (while alist
    (iiimcf-remove-handler
     (car (car alist)) nil)
    (setq alist (cdr alist))))

;;;

(defun iiimcf-server-control-parse-hostname (hostname)
  (if (string-match ":" hostname)
      (list
       (substring hostname 0 (match-beginning 0))
       (string-to-number (substring hostname (match-end 0))))
    (list
     hostname
     iiimcf-server-control-default-port)))

(defun iiimcf-server-control-convert-iiim-feedback
  (feedbacks type)
  (if (eq type 'face)
      (let (slot result)
	(while feedbacks
	  (setq slot (assq (car feedbacks)
			   iiimcf-server-control-preedit-face-alist)
		feedbacks (cdr feedbacks))
	  (if slot
	      (setq result (cons (nth 1 slot) result))))
	(nreverse result))
    nil))

(defun iiimcf-server-control-setup-event-flow-mode (mes)
  (setq iiimcf-server-control-dynamic-event-flow-p t))

(defun iiimcf-server-control-async-handler (com-id)
  (condition-case err
      (iiimcf-message-manager com-id nil)
    (iiimp-fatal
     (iiimcf-server-control-shutdown)
     (signal (car err) (cdr err)))))

(defun iiimcf-server-control-get-ic-attribute (com-id im-id)
  (let ((lang iiimcf-server-control-default-language)
	(im iiimcf-server-control-default-input-method))
    (if (null lang)
	(setq lang
	      (car
	       (iiimcf-server-control-com-id-get
		com-id 'language-list))))
    (nconc
     (list (cons 'input-language lang))
     ;; Currently, disabled, because the latest version of htt_server
     ;; accepts not attribid but string of the engin name.
     ;; This behavior clearly violates the specification.
     ;; (if im (list (cons 'input-method im)) nil)
     )))

(defun iiimcf-server-control-ic-setup (com-id im-id)
  (let (ic-id mes)
    (iiimp-send-message
     'iiimp-im-createic
     com-id im-id
     (iiimcf-server-control-get-ic-attribute
      com-id im-id))
    (setq mes
	  (iiimcf-message-manager
	   com-id
	   (list
	    (list 'iiimp-im-createic-reply
		  com-id im-id))))
    (setq ic-id (nth 3 mes))
    (iiimp-send-message 'iiimp-im-resetic com-id im-id ic-id)
    (iiimcf-message-manager
     com-id
     (list
      (list 'iiimp-im-resetic-reply
	    com-id im-id ic-id)))
    ic-id))

(defun iiimcf-server-control-ic-destruct (com-id im-id ic-id)
  (iiimp-send-message 'iiimp-im-resetic com-id im-id ic-id)
  (iiimcf-message-manager
   com-id
   (list
    (list 'iiimp-im-resetic-reply
	  com-id im-id ic-id)))
  (iiimp-send-message 'iiimp-im-destroyic com-id im-id ic-id)
  (iiimcf-message-manager
   com-id
   (list
    (list 'iiimp-im-destroyic-reply
	  com-id im-id ic-id))))

(defmacro iiimcf-server-control-ic-operation
  (x-com-id x-im-id x-ic-id &rest form)
  `(progn
     (iiimp-send-message
      'iiimp-im-seticfocus ,x-com-id ,x-im-id ,x-ic-id)
     (iiimcf-message-manager
      ,x-com-id
      (list
       (list
	'iiimp-im-seticfocus-reply
	,x-com-id ,x-im-id ,x-ic-id)))
     ,@form
     (iiimp-send-message
      'iiimp-im-unseticfocus ,x-com-id ,x-im-id ,x-ic-id)
     (iiimcf-message-manager
      ,x-com-id
      (list
       (list
	'iiimp-im-unseticfocus-reply
	,x-com-id ,x-im-id ,x-ic-id)))))

(defun iiimcf-server-control-dispatch-emacs-event
  (events &optional buf save-excursion-p)
  (let ((iiimcf-server-control-enable nil)
	(iiimcf-server-control-preedit-mode nil))
    (iiimcf-dispatch-emacs-event events buf save-excursion-p)))

(defun iiimcf-server-control-setup ()
  (if (and iiimcf-server-control-com-id
	   (not
	    (iiimp-check-channel-connection
	     iiimcf-server-control-com-id)))
      (iiimcf-server-control-shutdown))
  (if (null iiimcf-server-control-com-id)
      (setq iiimcf-server-control-com-id
	    (apply 
	     (function iiimp-create-network-channel)
	     (iiimcf-server-control-parse-hostname
	      (car iiimcf-server-control-hostlist)))))
  (iiimcf-server-control-register-com-id
   iiimcf-server-control-com-id)
  (let ((com-id iiimcf-server-control-com-id)
	mes)
    (iiimcf-server-control-register-handlers
     iiimcf-server-control-com-level-handler-alist
     com-id)
    (if (null iiimcf-server-control-im-id)
	(progn
	  (iiimp-send-message
	   'iiimp-im-connect
	   com-id
	   iiimcf-server-control-username)
	  (setq mes (iiimcf-message-manager
		     com-id
		     (list
		      (list 'iiimp-im-connect-reply com-id))))
	  (setq iiimcf-server-control-im-id
		(nth 2 mes))
	  (iiimcf-send-client-descriptor
	   com-id iiimcf-server-control-im-id
	   (format "IIIMCF-SC/%s"
		   iiimcf-server-control-version))))
    (if (null iiimcf-server-control-ic-id)
	(setq iiimcf-server-control-ic-id
	      (iiimcf-server-control-ic-setup
	       com-id iiimcf-server-control-im-id)))

    (iiimcf-server-control-register-handlers
     iiimcf-server-control-ic-level-handler-alist
     com-id
     iiimcf-server-control-im-id
     iiimcf-server-control-ic-id)

    (if iiimcf-server-control-async-invocation-p
	(iiimp-enable-async-invocation
	 com-id
	 (function iiimcf-server-control-async-handler)))))

(defun iiimcf-server-control-shutdown ()
  (inactivate-input-method)
  (if (or (null iiimcf-server-control-com-id)
	  (not (iiimp-check-channel-connection
		iiimcf-server-control-com-id)))
      (setq iiimcf-server-control-ic-id nil
	    iiimcf-server-control-im-id nil))
  (if iiimcf-server-control-ic-id
      (progn
	(iiimcf-server-control-ic-destruct
	 iiimcf-server-control-com-id
	 iiimcf-server-control-im-id
	 iiimcf-server-control-ic-id)
	(setq iiimcf-server-control-ic-id nil)))
  (if iiimcf-server-control-im-id
      (progn
	(iiimp-send-message
	 'iiimp-im-disconnect
	 iiimcf-server-control-com-id
	 iiimcf-server-control-im-id)
	(iiimcf-message-manager
	 iiimcf-server-control-com-id
	 (list
	  (list
	   'iiimp-im-disconnect-reply
	   iiimcf-server-control-com-id
	   iiimcf-server-control-im-id)))
	(setq iiimcf-server-control-im-id nil)))
  (if iiimcf-server-control-com-id
      (progn
	(while (not (iiimp-destroy-network-channel
		     iiimcf-server-control-com-id))
	  (sleep-for 1))
	(iiimcf-server-control-unregister-com-id
	 iiimcf-server-control-com-id)
	(setq iiimcf-server-control-com-id nil)))
  (setq iiimcf-server-control-dynamic-event-flow-p nil)

  (iiimcf-server-control-remove-handlers
   (append
    iiimcf-server-control-com-level-handler-alist
    iiimcf-server-control-ic-level-handler-alist)))

(defun iiimcf-server-control-inactivate ()
  "Inactivate IIIMCF server control input method."
  (interactive)
  (iiimcf-server-control-activate -1))

(defun iiimcf-server-control-notify-trigger (flag)
  (iiimp-send-message
   'iiimp-im-trigger-notify
   iiimcf-server-control-com-id
   iiimcf-server-control-im-id
   iiimcf-server-control-ic-id
   flag)
  (iiimcf-message-manager
   iiimcf-server-control-com-id
   (list
    (list 'iiimp-im-trigger-notify-reply
	  iiimcf-server-control-com-id
	  iiimcf-server-control-im-id
	  iiimcf-server-control-ic-id))))

(defun iiimcf-server-control-remove-minor-mode-map ()
  (let ((islot (assq 'iiimcf-server-control-enable
		     minor-mode-map-alist))
	(peslot (assq 'iiimcf-server-control-preedit-mode
		      minor-mode-map-alist)))
    (if islot
	(setq minor-mode-map-alist
	      (delq islot minor-mode-map-alist)))
    (if peslot
	(setq minor-mode-map-alist
	      (delq peslot minor-mode-map-alist)))))

(defun iiimcf-server-control-register-minor-mode-map ()
  (iiimcf-server-control-remove-minor-mode-map)
  (setq minor-mode-map-alist
	(append
	 (list (cons 'iiimcf-server-control-preedit-mode
		     iiimcf-server-control-preedit-state-keymap)
	       (cons 'iiimcf-server-control-enable
		     iiimcf-server-control-initial-state-keymap))
	 minor-mode-map-alist)))

(defun iiimcf-server-control-activate (&optional arg)
  (if (and arg
	  (< (prefix-numeric-value arg) 0))
      ;; inactivate
      (unwind-protect
	  (progn
	    (setq describe-current-input-method-function nil)
	    (if (iiimp-check-channel-connection
		 iiimcf-server-control-com-id)
		(iiimcf-server-control-notify-trigger nil))
	    (iiimcf-server-control-clear-preedit-text)
	    ;;(run-hooks 'iiimcf-server-control-inactivate-hook)
	    )
	(setq iiimcf-server-control-enable nil)
	(iiimcf-server-control-remove-minor-mode-map))

    ;; activate
    (setq iiimcf-server-control-enable t)
    (iiimcf-server-control-setup)
    (iiimcf-server-control-notify-trigger t)
    (setq inactivate-current-input-method-function
	  'iiimcf-server-control-inactivate)
    (setq describe-current-input-method-function
	  'iiimcf-server-control-help)

    ;; inactivate the current input method also in minibuffers
    ;; before exiting.
    (if (eq (selected-window) (minibuffer-window))
	(add-hook 'minibuffer-exit-hook
		  (function
		   iiimcf-server-control-exit-from-minibuffer)))
    ;;(run-hooks 'iiimcf-server-control-activate-hook)
    (iiimcf-server-control-register-minor-mode-map)))

(defun iiimcf-server-control-exit-from-minibuffer ()
  (inactivate-input-method)
  (if (<= (minibuffer-depth) 1)
      (remove-hook 'minibuffer-exit-hook
		   (function
		    iiimcf-server-control-exit-from-minibuffer))))

(defun iiimcf-server-control-keyforward (&optional ev)
  (interactive)
  (setq iiimcf-server-control-editing-buffer
	(current-buffer))
  (let* ((event (or ev
		    last-command-event))
	 (keyevent (iiimcf-translate-emacs-event event)))
    ;;(if (eq event ? ) (setq event 'convert))
    (if keyevent
	(condition-case err
	    (progn
	      (iiimp-send-message
	       'iiimp-im-forward-event
	       iiimcf-server-control-com-id
	       iiimcf-server-control-im-id
	       iiimcf-server-control-ic-id
	       (list 'keyevent
		     (list keyevent)))
	      ;; I have no idea why Solaris 8 IIIM server
	      ;; does not respond to IM_FORWARD_EVENT sometimes.
	      (iiimcf-message-manager
	       iiimcf-server-control-com-id
	       (list
		(list 'iiimp-im-forward-event-reply
		      iiimcf-server-control-com-id
		      iiimcf-server-control-im-id
		      iiimcf-server-control-ic-id)
		(list 'iiimp-im-forward-event
		      iiimcf-server-control-com-id
		      iiimcf-server-control-im-id
		      iiimcf-server-control-ic-id))))
	  (iiimp-fatal
	   (iiimcf-server-control-shutdown)
	   (signal (car err) (cdr err))))
      ;; Don't send an unattended event to server,
      ;; Deal with it by myself.
      (iiimcf-server-control-dispatch-emacs-event (list event)))
    nil))

(defun iiimcf-server-control-trigger-notify (mes)
  (let ((flag (nth 4 mes)))
    (if flag
	nil
      (inactivate-input-method))))

(defun iiimcf-server-control-forward-event (mes)
  (let ((con (nth 4 mes))
	kevslot1 kevslot2 kev)
    (iiimp-add-debug-log
     (format "FWD:%S\n" con))
    (if (eq (car con) 'keyevent)
	(progn
	  (setq kevslot1 (nth 1 con))
	  (while kevslot1
	    (if (setq kev
		      (iiimcf-translate-iiim-keyevent
		       (car kevslot1)))
		(setq kevslot2
		      (cons kev kevslot2)))
	    (setq kevslot1 (cdr kevslot1)))
	  (if kevslot2
	      (iiimcf-server-control-dispatch-emacs-event
	       (nreverse kevslot2)
	       (if iiimcf-server-control-editing-buffer
		   iiimcf-server-control-editing-buffer))
		)))))

;;;
;;; Select input method.
;;;

(defun iiimcf-server-control-completing-read
  (prompt annotated-collection)
  (let ((completion-setup-hook))
    (add-hook 'completion-setup-hook
	      (lambda ()
		(let ((inhibit-read-only t)
		      completion-setup-hook)
		  (save-excursion
		    (if (bufferp standard-output)
			(set-buffer standard-output))
		    (erase-buffer)
		    (display-completion-list
		     (mapcar
		      (lambda (x)
			(format "%s (%s)" x (cdr (assoc x annotated-collection))))
		      (all-completions
		       (save-excursion
			 (set-buffer (window-buffer (active-minibuffer-window)))
			 (buffer-string))
		       minibuffer-completion-table
		       minibuffer-completion-predicate
		       )))))))
    (completing-read prompt annotated-collection nil t)))

(defun iiimcf-server-control-maintain-language-list (mes)
  (iiimcf-server-control-com-id-put
   (nth 1 mes) 'language-list (nth 3 mes)))

(defun iiimcf-server-control-change-language ()
  (interactive)
  (inactivate-input-method)
  (setq iiimcf-server-control-default-language
	(iiimcf-server-control-completing-read
	 "Input Language:"
	 (mapcar
	  (lambda (x)
	    (cons x (iiimcf-get-language-description x)))
	  (iiimcf-server-control-com-id-get
	   iiimcf-server-control-com-id
	   'language-list))))
  (iiimcf-server-control-ic-destruct
   iiimcf-server-control-com-id
   iiimcf-server-control-im-id
   iiimcf-server-control-ic-id)
  (setq iiimcf-server-control-ic-id
	(iiimcf-server-control-ic-setup
	 iiimcf-server-control-com-id
	 iiimcf-server-control-im-id))
  (activate-input-method 'iiim-server-control))

(defun iiimcf-server-control-maintain-input-method-list (mes)
  (iiimcf-server-control-com-id-put
   (nth 1 mes)
   'input-method-list
   (nth 1 (assq 'input-method-list (nth 3 mes)))))

(defun iiimcf-server-control-change-input-method ()
  (interactive)
  (inactivate-input-method)
  (setq iiimcf-server-control-default-input-method
	(completing-read
	 "Input Method:"
	 (mapcar
	  (lambda (x)
	    (cons (nth 2 x) 0))
	  (iiimcf-server-control-com-id-get
	   iiimcf-server-control-com-id
	   'input-method-list))
	  nil t))
  (iiimcf-server-control-ic-destruct
   iiimcf-server-control-com-id
   iiimcf-server-control-im-id
   iiimcf-server-control-ic-id)
  (setq iiimcf-server-control-ic-id
	(iiimcf-server-control-ic-setup
	 iiimcf-server-control-com-id
	 iiimcf-server-control-im-id))
  (activate-input-method 'iiim-server-control))

;;;
;;; Preedit operations
;;;

(defsubst iiimcf-server-control-preedit-enable-p ()
  (> (length iiimcf-server-control-preedit) 0))

(defun iiimcf-server-control-put-face-to-preedit (str)
  (let ((len (length str))
	(pts 0)
	pte cprop)
    (while pts
      (setq cprop (get-text-property pts 'iiim-feedback str)
	    pte (next-single-property-change
		 pts 'iiim-feedback str))
      (if cprop
	  (put-text-property
	   pts (or pte len)
	   'face (iiimcf-server-control-convert-iiim-feedback
		  cprop 'face)
	   str))
      (setq pts pte))
    str))

(defun iiimcf-server-control-enclose-preedit-with-string (str caret)
  (let ((result "")
	(pts 0)
	(caretdiff 0)
	pte cprop cprop2 pprop
	elem slot hstr tstr)
    (while pts
      (setq cprop (get-text-property pts 'iiim-feedback str)
	    cprop2 cprop
	    pte (next-single-property-change
		 pts 'iiim-feedback str))
      (setq hstr "")
      (while (setq elem (car cprop))
	(if (memq elem pprop)
	    (setq pprop (delq elem pprop))
	  (if (setq slot (assq elem
			       iiimcf-server-control-preedit-face-alist))
	      (setq hstr (concat hstr (car (nth 2 slot))))))
	(setq cprop (cdr cprop)))
      (setq tstr "")
      (while pprop
	(if (setq slot (assq (car pprop)
			     iiimcf-server-control-preedit-face-alist))
	    (setq tstr (concat tstr (cdr (nth 2 slot)))))
	(setq pprop (cdr pprop)))
      (setq result (concat result tstr hstr (substring str pts pte)))
      (if (> caret pts) (setq caretdiff
			      (+ caretdiff
				 (length tstr)
				 (length hstr))))
      (setq pts pte
	    pprop cprop2))
    (while pprop
      (if (setq slot (assq (car pprop)
			   iiimcf-server-control-preedit-face-alist))
	  (setq result (concat result (cdr (nth 2 slot)))))
      (setq pprop (cdr pprop)))
    (cons result (+ caret caretdiff))))

(defun iiimcf-server-control-format-preedit (str caret)
  (if iiimcf-server-control-preedit-use-face-p
      (cons (iiimcf-server-control-put-face-to-preedit str)
	    caret)
    (iiimcf-server-control-enclose-preedit-with-string
     str caret)))

(defun iiimcf-server-control-setup-preedit-text ()
  (let ((prop-begin
	 '(iiimcf-server-control-preedit-start t intangible t))
	(prop-end
	 '(iiimcf-server-control-preedit-end t intangible t
	   rear-nonsticky t start-open t))
	(oldbuf (current-buffer))
	pss pse)
    ;; (if (string= " *IIIMP" (buffer-name oldbuf))
    ;;    (debug))
    (set-buffer iiimcf-server-control-editing-buffer)
    (setq pss (point))
    (let ((buffer-undo-list t))
      (insert iiimcf-server-control-preedit-open-string)
      (setq pse (point))
      (add-text-properties pss pse prop-begin) 
      (insert iiimcf-server-control-preedit-close-string)
      (add-text-properties pse (point) prop-end)
      (put-text-property pss (point) 'read-only t)
      (set-marker iiimcf-server-control-preedit-marker
		  pss)
      (set-marker-insertion-type
       iiimcf-server-control-preedit-marker t))
    (set-buffer oldbuf)))

(defun iiimcf-server-control-insert-preedit (text caret)
  (if (null (marker-position
	     iiimcf-server-control-preedit-marker))
      (iiimcf-server-control-setup-preedit-text))
  (let ((inhibit-read-only t)
	(inhibit-point-motion-hooks t)
	(oldbuf (current-buffer))
	(pts (marker-position
	      iiimcf-server-control-preedit-marker))
	pte)
    (set-buffer (marker-buffer
		 iiimcf-server-control-preedit-marker))
    (setq pte
	  (next-single-property-change
	   pts 'iiimcf-server-control-preedit-end))
    (if (null pte)
	(error "PREEDIT TEXT IS BROKEN!!"))
    (setq pts (+ pts (length iiimcf-server-control-preedit-open-string)))
    (let ((buffer-undo-list t))
      (delete-region pts pte)
      (goto-char pts)
      (insert text)
      (put-text-property pts (point) 'read-only t)
      (goto-char (+ pts caret)))
    (set-buffer oldbuf)))

(defun iiimcf-server-control-show-preedit-minibuffer-p ()
  (and input-method-use-echo-area
       (null
	(marker-position
	 iiimcf-server-control-preedit-marker))))

(defun iiimcf-server-control-show-preedit-in-minibuffer (disptext caret)
  (let (pt mbuf)
    (save-excursion
      ;; clear echo area.
      (message nil)
      (setq mbuf (window-buffer (minibuffer-window)))
      (set-buffer mbuf)
      (erase-buffer)
      (insert "Preedit:")
      (setq pt (point))
      (insert disptext " ")
      ; (move-overlay
      ;  iiimcf-server-control-caret-overlay
      ;  (+ pt caret) (+ 1 pt caret) mbuf)
      )))

(defun iiimcf-server-control-maintain-preedit-text-internal
  (mes &optional init)
  (let* ((caret (nth 4 mes))
	 (ch-first (nth 5 mes))
	 (ch-len (nth 6 mes))
	 (ch-second (+ ch-first ch-len))
	 (contents (nth 7 mes))
	 (str (nth 1 contents))
	 (len (length iiimcf-server-control-preedit))
	 disptext head tail)
    (if (and (>= len ch-first)
	     (> ch-first 0))
	(setq head (substring
		    iiimcf-server-control-preedit
		    0 ch-first)))
    (if (> len ch-second)
	(setq tail (substring
		    iiimcf-server-control-preedit
		    ch-second)))
    (setq iiimcf-server-control-preedit (concat head str tail)
	  disptext (iiimcf-server-control-format-preedit
		    iiimcf-server-control-preedit caret)
	  caret (cdr disptext)
	  disptext (car disptext))

    (if (iiimcf-server-control-preedit-enable-p)
	;; Show preedit text.
	(if (iiimcf-server-control-show-preedit-minibuffer-p)
	    (iiimcf-server-control-show-preedit-in-minibuffer
	     disptext caret)
	  (if init
	      (iiimcf-server-control-setup-preedit-text))
	  (iiimcf-server-control-insert-preedit disptext caret))
      (iiimcf-server-control-clear-preedit-text))))

(defun iiimcf-server-control-maintain-preedit-text (mes)
  (let (;; disable the font-lock function invoked by
	;; after-change-functions during preedit.
	;; Even read-only text-property cannot protect inserted preedit
	;; text from modifications of the face text-property by font-lock.
	(font-lock-fontify-region-function (function ignore)))
    (if (iiimcf-server-control-preedit-enable-p)
	(iiimcf-server-control-maintain-preedit-text-internal mes)
      ;; initialize preedit text.
      (iiimcf-server-control-maintain-preedit-text-internal mes t)))
  ;; set iiimcf-server-control-preedit-mode flag
  (save-excursion
    (set-buffer iiimcf-server-control-editing-buffer)
    (setq iiimcf-server-control-preedit-mode
	  (iiimcf-server-control-preedit-enable-p))))

(defun iiimcf-server-control-clear-preedit-text ()
  (setq iiimcf-server-control-preedit "")
  (if (iiimcf-server-control-show-preedit-minibuffer-p)
      ;; erase minibuffer.
      (save-excursion
	(let ((mbuf (window-buffer (minibuffer-window))))
	  (set-buffer mbuf)
	  (erase-buffer)
	  ;; (move-overlay
	  ;; iiimcf-server-control-caret-overlay
	  ;; 0 0 mbuf)
	  ))
    ;; Erase inserted preedit.
      (let ((pts (marker-position
		  iiimcf-server-control-preedit-marker))
	    (inhibit-read-only t)
	    pte)
	(if pts
	    (progn
	      (save-excursion
		(set-buffer (marker-buffer
			     iiimcf-server-control-preedit-marker))
		(setq pte
		      (next-single-property-change
		       pts 'iiimcf-server-control-preedit-end))
		(if (null pte)
		    (error "PREEDIT TEXT BROKEN!!"))
		(let ((buffer-undo-list t))
		  (delete-region
		   pts (+ pte
			  (length
			   iiimcf-server-control-preedit-close-string)))))
	      (goto-char pts)
	      (set-marker iiimcf-server-control-preedit-marker nil))))))

(defun iiimcf-server-control-prepare-lookup-choice (mes)
  (setq iiimcf-server-control-lookup-choice-configuration mes))

(defun iiimcf-server-control-draw-lookup-choice (mes)
  (if (null iiimcf-server-control-lookup-choice-configuration)
      (error "IM_LOOKUP_CHOICE_START is missing."))
  (with-output-to-temp-buffer "*Lookup choice*"
    (save-excursion
     (set-buffer standard-output)
     (let ((i 0)
	   (k 0)
	   (num (nth 5 iiimcf-server-control-lookup-choice-configuration))
	   (rows (nth 6 iiimcf-server-control-lookup-choice-configuration))
	   (cols (nth 7 iiimcf-server-control-lookup-choice-configuration))
	   (idxfirst (nth 4 mes))
	   (idxlast (nth 5 mes))
	   (idxcur (nth 6 mes))
	   (candlist (nth 7 mes))
	   (lblist (nth 8 mes))
	   (title (nth 9 mes))
	   curcand curlb)
       (setq iiimcf-server-control-current-lookup-choice
	     (list idxfirst candlist lblist title idxfirst idxlast))
       (insert (format "Title:%s\n" title))
       (while (and (> num i)
		   (setq curcand (car candlist))
		   (setq curlb (car lblist)))
	 (insert (format "%s : %s    " curlb curcand))
	 (setq i (1+ i)
	       k (1+ k))
	 (if (>= k rows)
	     (progn
	       (setq k 0)
	       (insert "\n")))
	 (setq candlist (cdr candlist)
	       lblist (cdr lblist)))))))

(defun iiimcf-server-control-redraw-lookup-choice (mes)
  (if (or (null iiimcf-server-control-lookup-choice-configuration)
	  (null iiimcf-server-control-current-lookup-choice))
      (error "IM_LOOKUP_CHOICE_START is missing."))
  (with-output-to-temp-buffer "*Lookup choice*"
    (save-excursion
     (set-buffer standard-output)
     (let ((i 0)
	   (k 0)
	   (num (nth 5 iiimcf-server-control-lookup-choice-configuration))
	   (rows (nth 6 iiimcf-server-control-lookup-choice-configuration))
	   (cols (nth 7 iiimcf-server-control-lookup-choice-configuration))
	   (idx (car iiimcf-server-control-current-lookup-choice))
	   (lblist (nth 1 iiimcf-server-control-current-lookup-choice))
	   (candlist (nth 2 iiimcf-server-control-current-lookup-choice))
	   (title (nth 3 iiimcf-server-control-current-lookup-choice))
	   (idxfirst (nth 4 iiimcf-server-control-current-lookup-choice))
	   (idxlast (nth 5 iiimcf-server-control-current-lookup-choice))
	   (type (nth 4 mes))
	   (val (nth 5 mes))
	   curcand curlb)
       (cond ((eq type 'index)
	      (setq idx val))
	     ((eq type 'page)
	      (cond ((eq val 'next)
		     (setq idx (+ idx num)))
		    ((eq val 'prev)
		     (setq idx (- idx num)))
		    ((eq val 'first)
		     (setq idx idxfirst))
		    ((eq val 'last)
		     (setq idx (- idxlast num))))))
       (setcar iiimcf-server-control-current-lookup-choice idx)
       (setq lblist (nthcdr (- idx idxfirst) lblist))
       (setq candlist (nthcdr (- idx idxfirst) candlist))
       (while (and (> num i)
		   (setq curcand (car candlist))
		   (setq curlb (car lblist)))
	 (insert (format "%s : %s    " curlb curcand))
	 (setq i (1+ i)
	       k (1+ k))
	 (if (>= k rows)
	     (progn
	       (setq k 0)
	       (insert "\n")))
	 (setq candlist (cdr candlist)
	       lblist (cdr lblist)))))))

(defun iiimcf-server-control-clear-lookup-choice (mes)
;;  (setq iiimcf-server-control-lookup-choice-configuration nil
;;	  iiimcf-server-control-current-lookup-choice nil)
  (let* ((buf (get-buffer "*Lookup choice*"))
	 (win (get-buffer-window buf)))
    (if win (delete-window win))))

(defun iiimcf-server-control-draw-status (mes)
  (setq iiimcf-server-control-mode-line
	(format "[%s]" (nth 1 (nth 4 mes))))
  (force-mode-line-update))

(defun iiimcf-server-control-draw-aux-data (mes)
  (let ((name (nth 5 mes))
	(strs (nth 7 mes)))
    (cond ((string-match "^jp\\.co\\.justsystem\\..*LookupAux$"
			 name)
	   (if strs
	       (message "%s:  %s"
			(car strs)
			(mapconcat 
			 (function identity)
			 (cdr strs) " "))
	     (message ""))))))
  

(defun iiimcf-server-control-commit-string (mes)
  (let ((str (copy-sequence (nth 1 (nth 4 mes))))
	(oldbuf (current-buffer))
	(buf (marker-buffer
	      iiimcf-server-control-preedit-marker))
	(pt (marker-position
	     iiimcf-server-control-preedit-marker))
	generated-events)
    (set-text-properties 0 (length str) nil str)
    (if pt
	(progn
	  (set-buffer buf)
	  (goto-char pt))
      (set-buffer iiimcf-server-control-editing-buffer))
    (setq generated-events (iiimcf-emacs-string-to-events str))
    ;; dispatch them immediately!
    (iiimcf-server-control-dispatch-emacs-event generated-events)
    ;; (insert str)
    (if pt (set-marker
	    iiimcf-server-control-preedit-marker
	    (point)))
    (set-buffer oldbuf)
    (run-hooks 'input-method-after-insert-chunk-hook)))

(register-input-method
 "iiim-server-control" "Japanese"
 'iiimcf-server-control-activate
 ""  "IIIM server control input method")

(provide 'iiimcf-sc)

;; iiimcf-sc.el ends here.
