;;; tc-sysdep.el --- system-dependent routines & variables for T-Code
;;
;; Copyright (C) 1997 Kaoru Maeda, Yasushi Saito and Akira Kitajima.

;; Author: Kaoru Maeda <maeda@src.ricoh.co.jp>
;;	Yasushi Saito <yasushi@is.s.u-tokyo.ac.jp>
;;	Akira Kitajima <kitajima@ics.es.osaka-u.ac.jp>
;; Maintainer: Akira Kitajima
;; Version: $Id: tc-sysdep.el,v 2.0.9.1 2000/05/13 14:31:12 akira Exp $

;; 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 of the License, 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 this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA.

;;; Code:

(defconst tcode-emacs-version
  (cond ((string-match "XEmacs" emacs-version)
	 'xemacs)
	((and (boundp 'mule-version)
	      (>= (string-to-int mule-version) 4))
	 'mule-4)
	((and (boundp 'mule-version)
	      (= (string-to-int mule-version) 3))
	 'mule-3)
	((numberp (string-match "^19" emacs-version))
	 'mule-2)
	((featurep 'mule)
	 'mule-1)
	(t
	 'nemacs))
  "ܸEmacsΥס
nemacs, mule-1, mule-2, mule-3, mule-4, xemacsΤ줫")

(defmacro tcode-xemacs-p ()
  (list 'eq 'tcode-emacs-version (list 'quote 'xemacs)))

(defmacro tcode-mule-4-p ()
  (list 'eq 'tcode-emacs-version (list 'quote 'mule-4)))

(defmacro tcode-mule-3-p ()
  (list 'eq 'tcode-emacs-version (list 'quote 'mule-3)))

(defmacro tcode-mule-2-p ()
  (list 'eq 'tcode-emacs-version (list 'quote 'mule-2)))

(defmacro tcode-mule-1-p ()
  (list 'eq 'tcode-emacs-version (list 'quote 'mule-1)))

(defmacro tcode-nemacs-p ()
  (list 'eq 'tcode-emacs-version (list 'quote 'nemacs)))

;; Nemacs doesn't have 'egg feature.
(if (featurep 'wnn-egg) (provide 'egg))
(if (featurep 'wnn4-egg) (provide 'egg))

(if (featurep 'egg)
    (or (boundp 'mc-flag)
	(setq mc-flag t)))

;;;
;;; Define some new functions that are not present in Emacs 18.
;;;

;;; `unless' and `when' are from subr.el of emacs-20.2.
(or (fboundp 'unless)
    (progn
      (defmacro unless (cond &rest body)
	"(unless COND BODY...): if COND yields nil, do BODY, else return nil."
	(cons 'if (cons cond (cons nil body))))
      (put 'unless 'lisp-indent-function 1)
      (put 'unless 'edebug-form-spec '(&rest form))))

(unless (fboundp 'when)
  (defmacro when (cond &rest body)
    "(when COND BODY...): if COND yields non-nil, do BODY, else return nil."
    (list 'if cond (cons 'progn body)))
  (put 'when 'lisp-indent-function 1)
  (put 'when 'edebug-form-spec '(&rest form)))

(or (fboundp 'add-hook)
    (defun add-hook (hook fun)
      "Add to the value of HOOK the function FUNCTION.
FUNCTION is added at the beginning of the hook list.

HOOK should be a symbol, and FUNCTION may be any valid function.  If
HOOK is void, it is first set to nil.  If HOOK's value is a single
function, it is changed to a list of functions."
      (if (not (boundp hook)) (set hook nil))
      (let ((cur-value (eval hook)))
	(cond ((or (equal fun cur-value)
		   (and (consp cur-value)
			(member fun cur-value)))
	       nil)			; already defined
	      ((null cur-value)
	       (set hook fun))
	      ((or (not (consp cur-value))
		   (eq (car cur-value) 'lambda))
	       (set hook (cons fun (list cur-value))))
	      (t
	       (set hook (nconc (list fun) cur-value)))))))

(or (fboundp 'cancel-undo-boundary)
    (defun cancel-undo-boundary ()
      ;; this function is just a dummy for emacs version 18,
      ;; and it actually does nothing
      nil))

(or (fboundp 'chars-in-string)
    (defun chars-in-string (s)
      (length s)))

(or (fboundp 'make-character)
    (cond ((or (tcode-mule-3-p)
	       (tcode-mule-4-p))
	   (defun make-character (lc c1 c2)
	     (make-char lc c1 c2)))
	  ((tcode-xemacs-p)
	   (defun make-character (lc c1 c2)
	     (make-char lc (- c1 128) (- c2 128))))
	  (t
	   ;; NEmacs
	   (defmacro make-character (lc c1 c2)
	     (list 'tcode-string-to-char (list 'format "%c%c" c1 c2))))))

(or (fboundp 'delete-text-in-column)
    ;;; from mule-util.el
    (defun delete-text-in-column (from to)
      "Delete the text between column FROM and TO (exclusive) of the current line.
Nil of FORM or TO means the current column.
If there's a charcter across the borders, the character is replaced with
the same width of spaces before deleting."
      (save-excursion
	(let (p1 p2)
	  (if from
	      (progn
		(setq p1 (move-to-column from))
		(if (> p1 from)
		    (progn
		      (delete-char -1)
		      (insert-char ?  (- p1 (current-column)))
		      (forward-char (- from p1))))))
	  (setq p1 (point))
	  (if to
	      (progn
		(setq p2 (move-to-column to))
		(if (> p2 to)
		    (progn
		      (delete-char -1)
		      (insert-char ?  (- p2 (current-column)))
		      (forward-char (- to p2))))))
	  (setq p2 (point))
	  (delete-region p1 p2)))))

(or (fboundp 'member)
    (defun member (elt list)
      "Return non-nil if ELT is an element of LIST.  \
Comparison done with `equal'.
The value is actually the tail of LIST whose car is ELT."
      (catch 'found
	(while list
	  (and (equal elt (car list))
	       (throw 'found list))
	  (setq list (cdr list))))))

(or (fboundp 'frame-width)
    (defmacro frame-width () (list 'screen-width)))

(or (fboundp 'abs)
    (defun abs (arg)
      "Return the absolute value of ARG."
      (if (>= arg 0) arg (- arg))))

;;;
;;; Fix incompatibilities between 18 and 19.
;;;
(if (string-match "^\\(19\\|2[01]\\)" emacs-version)
    (progn
      (defun tcode-define-key-for-all-chars (keymap fun)
	"ޥå KEYMAP ΡʸΤФ륨ȥ
FUN롣KEYMAPϡ(make-keymap)Ǻ줿ޥåפǤʤ
ʤʤ"
	(let ((i 0))
	  (while (< i 126)
	    (define-key keymap (char-to-string i) fun)
	    (setq i (1+ i)))))
      (defun tcode-redo-last-command ()
	"ľϤ줿򸽺ߤΥޥåפǺƼ¹Ԥ"
	(setq unread-command-events
	      (cons last-command-event unread-command-events)))
      (defun tcode-redo-command (ch)
	" CH 򸽺ߤΥޥåפǺƼ¹Ԥ"
	(setq unread-command-events
	      (cons (character-to-event ch) unread-command-events)))
      (or (fboundp 'character-to-event)
	  (defun character-to-event (ch)
	    ch))
      ;; XEmacs
      (or (fboundp 'isearch-last-command-char)
	  (defun isearch-last-command-char ()
	    last-command-char))
      (or (boundp 'search-upper-case)
	  (setq search-upper-case 'not-yanks)))
  ;; NEmacs
  (defun tcode-define-key-for-all-chars (keymap fun)
    "ޥå KEYMAP ΡƤʸФ륨ȥFUN롣
KEYMAPϡ(make-keymap)Ǻ줿ޥåפǤʤФʤʤ"
    (let ((i 0))
      (while (< i 126)
	(aset keymap i fun)
	(setq i (1+ i)))))
  (defun tcode-redo-last-command ()
    "ľϤ줿򸽺ߤΥޥåפǺƼ¹Ԥ"
    (setq unread-command-char last-command-char))
  (defun tcode-redo-command (ch)
    " CH 򸽺ߤΥޥåפǺƼ¹Ԥ"
    (setq unread-command-char ch)))

(if (not (tcode-nemacs-p))
    (progn
      (defmacro tcode-char-width (p) (list 'char-width p))
      (defmacro tcode-string-to-char (p) (list 'string-to-char p))
      (defmacro tcode-char-after (p) (list 'char-after p))
      (defmacro tcode-char-before (p) (list 'char-before p))
      (defmacro tcode-forward-char (p) (list 'forward-char p))
      (defmacro tcode-backward-char (p) (list 'backward-char p))
      (defmacro tcode-string-to-char-list (p) (list 'string-to-char-list p))
      (or (fboundp 'string-to-char-list)
	  (defun string-to-char-list (p)
	    (string-to-list p)))
      (defmacro tcode-delete-char (p) (list 'delete-char p)))
  ;;;
  ;;; NEmacs Ѥ
  ;;; ʲδؿǤϡ2ХʸͤѴȡ
  ;;; (1Х*256 + 2Х)ˤʤ롣
  ;;;
  (defun tcode-char-width (c)
    (if (> c 256) 2 1))
  (unless (fboundp 'orig:char-to-string)
    (fset 'orig:char-to-string (symbol-function 'char-to-string))
    (defun char-to-string (c)
      (if (> c 256)
	  (format "%c%c" (/ c 256) (mod c 256))
	(orig:char-to-string c))))
  (defun tcode-string-to-char (s)
    (let ((1st (aref s 0)))
      (if (>= 1st 128)
          (+ (* 1st 256) (aref s 1))
        1st)))
  (defun tcode-char-after (p)
    (let ((1st (char-after p)))
      (if (>= 1st 128)
          (+ (* 1st 256) (char-after (1+ p)))
        1st)))
  (defun tcode-char-before (p)
    (save-excursion
      (goto-char p)
      (forward-char -1)
      (tcode-char-after (point))))
  (defmacro tcode-string-to-char-list (s)
    (list 'kanji-word-list s))
  (defun tcode-forward-char (i)
    (if (< i 0)
	(while (< i 0)
	  (if (>= (preceding-char) 128) (backward-char 2)
	    (backward-char 1))
	  (setq i (1+ i)))
      (while (> i 0)
	(if (>= (char-after (point)) 128) (forward-char 2)
	  (forward-char 1))
	(setq i (1- i)))))
  (defmacro tcode-backward-char (i)
    (list 'tcode-forward-char (list '- 0 i)))

  (defun tcode-delete-char (i)
    (if (< i 0)
	(while (< i 0)
	  (if (>= (preceding-char) 128)
	      (delete-char -2)
	    (delete-char -1))
	  (setq i (1+ i)))
      (while (> i 0)
	(if (>= (char-after (point)) 128)
	    (delete-char 2)
	  (delete-char 1))
	(setq i (1- i)))))

  (defmacro string-width (p) (list 'length p)))

(defun tcode-do-auto-fill ()
  (cond ((fboundp 'egg:do-auto-fill)	(egg:do-auto-fill))
	((boundp 'auto-fill-function)
	 ;; emacs-19
	 (and auto-fill-function
	      (> (current-column) fill-column)
	      (funcall auto-fill-function)))
	(t
	 ;; emacs-18
	 (and auto-fill-hook
	      (> (current-column) fill-column)
	      (do-auto-fill)))))

;;; for Mule 3.*
(when (or (tcode-mule-3-p)
	  (tcode-mule-4-p))
  (defvar lc-jp 'japanese-jisx0208)
  (unless (fboundp 'char-component)
    (if (fboundp 'split-char)
	(defun char-component (ch addr)
	  (nth addr (split-char ch)))
      (defun char-component (ch addr)
	(aref (char-to-string ch) addr)))))

;;; for XEmacs
(when (tcode-xemacs-p)
  (or (boundp 'lc-jp)
      (defvar lc-jp 'japanese-jisx0208))
  (or (fboundp 'char-component)
      (defun char-component (ch addr)
	(+ (char-octet ch (1- addr)) 128))))

;;; support custom package

(or (fboundp 'defgroup)
    (defmacro defgroup (&rest args)))

(or (fboundp 'defcustom)
    (defmacro defcustom (symbol value doc &rest args)
      (list 'defvar symbol value doc)))

(defgroup input-methods nil
  "Input methods."
  :group 'mule)

(defgroup tcode nil
  "T-Code (Kanji direct input method)."
  :group 'input-methods)

;;; from mule-cmds.el of Emacs 20.0.91 for earlier version

(unless (boundp 'input-method-activate-hook)
  (defvar input-method-activate-hook nil
    "Normal hook run just after an input method is activated.")

  (defvar input-method-inactivate-hook nil
    "Normal hook run just after an input method is inactivated.")

  (defvar input-method-after-insert-chunk-hook nil
    "Normal hook run just after an input method insert some chunk of text."))


;;; from mule-cmds.el of Emacs 20.3 for earlier version

(unless (boundp 'input-method-verbose-flag)
  (defcustom input-method-verbose-flag 'default
    "*A flag to control extra guidance given by input methods.
The value should be nil, t, `complex-only', or `default'.

The extra guidance is done by showing list of available keys in echo
area.  When you use the input method in the minibuffer, the guidance
is shown at the bottom short window (split from the existing window).

If the value is t, extra guidance is always given, if the value is
nil, extra guidance is always suppressed.

If the value is `complex-only', only complex input methods such as
`chinese-py' and `japanese' give extra guidance.

If the value is `default', complex input methods always give extra
guidance, but simple input methods give it only when you are not in
the minibuffer.

See also the variable `input-method-highlight-flag'."
    :type '(choice (const t) (const nil) (const complex-only) (const default))
    :group 'mule)

  (defcustom input-method-highlight-flag t
    "*If this flag is non-nil, input methods highlight partially-entered text.
For instance, while you are in the middle of a Quail input method sequence,
the text inserted so far is temporarily underlined.
The underlining goes away when you finish or abort the input method sequence.
See also the variable `input-method-verbose-flag'."
    :type 'boolean
    :group 'mule))

;;; mode-line
(defconst tcode-egg-mode-line
  (and (featurep 'egg)
       (fboundp 'mode-line-egg-mode-update)))

(defun tcode-find-symbol-in-tree (item tree)
  "ITEM Ǥդι¤Υꥹ TREE equalõ
Ĥt, Ĥʤ nil"
  (if (consp tree)
      (or (tcode-find-symbol-in-tree item (car tree))
	  (tcode-find-symbol-in-tree item (cdr tree)))
    (equal item tree)))

;;; set mode-line-format
(or tcode-egg-mode-line
    (and (boundp 'tcode-mode-indicator)
	 (tcode-find-symbol-in-tree 'tcode-mode-indicator
				    (default-value 'mode-line-format)))
    (cond ((or (tcode-nemacs-p)
	       (tcode-xemacs-p))
	   (setq-default mode-line-format
			 (cons '(tcode-ready-in-this-buffer
				 ("[" tcode-mode-indicator "]"))
			       (default-value 'mode-line-format))))
	  ((or (tcode-mule-1-p)
	       (tcode-mule-2-p))
	   (setq-default mode-line-format
			 (cons '(mc-flag ("[" tcode-mode-indicator "]"))
			       (default-value 'mode-line-format))))
	  ((tcode-mule-3-p)
	   (setq-default mode-line-mule-info
			 '(enable-multibyte-characters
			   ((current-input-method-title
			     ("[" current-input-method-title "]"))
			    "%Z"))))
	  ((tcode-mule-4-p)
	   (setq-default mode-line-mule-info
			 '("" (current-input-method-title
			       ("[" current-input-method-title "]")) "%Z")))))

(defvar tcode-mode-indicator 'current-input-method-title)
(unless (boundp 'current-input-method-title)
  (defvar current-input-method-title "--")
  (make-variable-buffer-local 'current-input-method-title)
  (setq-default current-input-method-title "--"))

;;; for toggle-input-method
(unless (or (tcode-nemacs-p)
	    (tcode-mule-1-p)
	    (tcode-mule-2-p)
	    (and (tcode-xemacs-p)
		 (< emacs-major-version 21)
		 (< emacs-minor-version 3)))
  (defvar tcode-previous-package nil)
  (defvar tcode-transparent-mode-indicator "--")
  (defadvice inactivate-input-method (after
				      turn-off-current-input-method-title
				      activate)
    "Turn off `current-input-method-title' for mode line."
    (and (string= (car input-method-history)
		  tcode-previous-package)
	 (setq current-input-method-title
	       tcode-transparent-mode-indicator)))
  (defvar tcode-package-name-alist
    '(("japanese-T-Code" . "tc-tbl")
      ("japanese-TUT-Code" . "tutc-tbl"))
    "̾ȥơ֥̾Ȥб")
  (defun tcode-use-package (package-name &rest libraries)
    "Start using T-Code package PACKAGE-NAME.
The remaining arguments are libraries to be loaded before using the package."
    (if (equal tcode-previous-package package-name)
	()
      (let ((table-name (cdr (assoc package-name
				    tcode-package-name-alist))))
	(or table-name
	    (error "No package named %s" package-name))
	(while libraries
	  (load (car libraries))
	  (setq libraries (cdr libraries)))
	(tcode-load-table table-name))
      (setq tcode-previous-package package-name))
    (setq inactivate-current-input-method-function 'tcode-inactivate
	  describe-current-input-method-function 'tcode-mode-help)
    (setq current-input-method-title 'tcode-mode-indicator)
    (tcode-activate)))

(unless (fboundp 'toggle-input-method)
  (defvar tcode-mode nil)
  (defun toggle-input-method (&optional arg)
      ;; only toggle tcode-mode
      (interactive "P")
      (unless (and arg
		   (or (and (tcode-on-p)
			    (> (prefix-numeric-value arg) 0))
		       (and (not (tcode-on-p))
			    (<= (prefix-numeric-value arg) 0))))
	(if tcode-mode
	    (tcode-inactivate)
	  (tcode-activate)))))


(provide 'tc-sysdep)

;;; tc-sysdep.el ends here