;;; tc-is19.el --- T-Code isearch modification for Mule [23].x.

;; Copyright (C) 1994,97 Kaoru Maeda, Mikihiko Nakao and KITAJIMA Akira

;; Author: Kaoru Maeda   (maeda@src.ricoh.co.jp)
;;	Mikihiko Nakao (nakao)
;;	KITAJIMA Akira <kitajima@ics.es.osaka-u.ac.jp>
;; Maintainer: KITAJIMA Akira

;; $Id: tc-is19.el,v 2.0.8.0 2000/03/04 05:50:50 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.

;; 94.8.25  Modified for T-Code by M.Nakao
;; 94.10.05 Modified by M.Nakao
;;	* bushu in TC-I-search.
;; 94.11.08 Modified by Kaoru Maeda.
;;	* isearch-delete-char can delete the last incomplete tcode stroke.
;;	* add code for tcode-isearch-start-state.
;; 97.4.3   Modified by KITAJIMA Akira.
;;	* dealing with multi-stroke input.
;; 97.7.30  Modified by KITAJIMA Akira.
;;	* modify for mule-3.x.
;; 97.9.25  Modified by KITAJIMA Akira.
;;	* modify for XEmacs-20.2.
;;
;; some of following codes are stolen from isearch.el for mule-2.x:
;;
;; isearch.el --- incremental search minor mode.
;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
;; Author: Daniel LaLiberte <liberte@cs.uiuc.edu>
;; |\044Date: 1994/05/14 09:50:26 \044|\044Revision: 1.69 \044
;;
;; Comment from Kaoru: strange \044 above denotes Daniel's original RCS Id.

;;; Code:

(if (<= (string-to-int emacs-version) 18)
    (error "tc-is19 cannot run on Nemacs/mule-1.x.  Use Mule-2.0 or later!"))

;;;
;;;  User Variables
;;;
(defvar tcode-isearch-start-state nil
  "*T-Code󥯥󥿥륵ϻT-Code⡼ɤꤹ롣
	nil: Хåեtcode-modeƱ(ǥե)
	t:   Хåեtcode-modeΩϻϥХåեƱ
	0:   ХåեΩ˾non-T-Code鳫ϡ
	1:   ХåեΩ˾T-Code鳫ϡ
Хåեѿ")
(make-variable-buffer-local 'tcode-isearch-start-state)
(setq-default tcode-isearch-start-state nil)

(defcustom tcode-isearch-enable-wrapped-search nil
  "*2ХʸǥȤˡԤ̵뤹롣"
  :type 'boolean :group 'tcode)

(defcustom tcode-isearch-ignore-regexp "[\n \t]*"
  "* 2Хʸ֤ɽ
`tcode-isearch-enable-wrapped-search'  t ΤȤΤͭ"
  :type 'regexp :group 'tcode)

(defcustom tcode-isearch-special-function-alist
  '((tcode-bushu-henkan . tcode-isearch-bushu-henkan-command)
    (tcode-bushu-another-henkan . tcode-isearch-bushu-henkan-command)
    (tcode-mazegaki-alternative-start . tcode-isearch-prefix-mazegaki)
    (tcode-mazegaki-start . tcode-isearch-postfix-mazegaki))
  "*isearchǤüʥޥɤϤФإޥɤ alist"
  :group 'tcode)

;;;
;;;  Internal Variable
;;;
(defvar tcode-isearch-active nil
  "󥯥󥿥륵 T-Code ⡼ɤΤȤ non-nil")

;;;
;;; Default key binding
;;;
(define-key isearch-mode-map "\C-\\" 'isearch-toggle-tcode)
(put 'isearch-toggle-tcode 'isearch-command t) ; for XEmacs

;;;
;;; Functions
;;;
(defun isearch-message-prefix (&optional c-q-hack ellipsis nonincremental)
  ;; If about to search, and previous search regexp was invalid,
  ;; check that it still is.  If it is valid now,
  ;; let the message we display while searching say that it is valid.
  (and isearch-invalid-regexp ellipsis
       (condition-case ()
	   (progn (re-search-forward isearch-string (point) t)
		  (setq isearch-invalid-regexp nil
			isearch-within-brackets nil))
	 (error nil)))
  ;; If currently failing, display no ellipsis.
  (or isearch-success (setq ellipsis nil))
  (let ((m (concat (if isearch-success "" "failing ")
		   (if isearch-wrapped "wrapped ")
		   (if isearch-word "word " "")
		   (if isearch-regexp "regexp " "")
		   (if tcode-isearch-active "TC-" "")
		   (if nonincremental "search" "I-search")
		   (if isearch-forward ": " " backward: ")
		   )))
    (aset m 0 (upcase (aref m 0)))
    m))


(defun isearch-toggle-tcode ()
  "󥯥󥿥륵 T-Code ⡼ɤȥ뤹롣
󥯥󥿥륵 prefix/postfix ѴȤޤ"
  (interactive)
  (setq tcode-isearch-active (not tcode-isearch-active))
  (if tcode-isearch-start-state
      ()
    (toggle-input-method))
  (isearch-update))

(defun tcode-isearch-bushu-henkan (c1 c2)
  ;; 󥯥󥿥륵 C1  C2 ȤѴ롣
  (let ((s (tcode-lookup-outset c1 c2)))
    (if (stringp s)
	(progn
	  (isearch-delete-char)
	  (isearch-delete-char)
	  (isearch-process-search-string
	   (tcode-isearch-make-string-for-wrapping s) s))
      (ding)
      (isearch-update))))

(defun tcode-isearch-process-string (str prev)
  "ʸ STR 򸡺ʸ˲äƸ롣
PREV ȹǤȤϤιʸǸ롣"
  (if (not (stringp prev))
      (isearch-process-search-string
       (tcode-isearch-make-string-for-wrapping str) str)
    (tcode-isearch-bushu-henkan prev str)))

(defun isearch-printing-char ()
  "Add this ordinary printing character to the search string and search."
  (interactive)
  (if (not tcode-isearch-active)
      (isearch-process-search-char (isearch-last-command-char))
    (let ((action (tcode-get-action-from-table (isearch-last-command-char) t))
	  (prev (tcode-isearch-bushu)))
      (cond ((null action)
	     (ding))
	    ((stringp action)
	     (tcode-isearch-process-string action prev))
	    ((char-or-string-p action)
	     (tcode-isearch-process-string (char-to-string action)
					   prev))
	    ((and (not (tcode-function-p action))
		  (consp action))
	     (tcode-isearch-process-string (mapconcat 'identity action "")
					   prev))
	    ((tcode-function-p action)
	     (let ((function
		    (cdr (assq action
			       tcode-isearch-special-function-alist))))
	       (if function
		   (funcall function)
		 (ding))))
	    (t
	     (ding))))))

(defun isearch-search ()
  ;; Do the search with the current search string.
  (isearch-message nil t)
  (if (and (eq isearch-case-fold-search t) search-upper-case)
      (setq isearch-case-fold-search
	    (if (tcode-xemacs-p)
		(isearch-no-upper-case-p isearch-string)
	      (isearch-no-upper-case-p isearch-string isearch-regexp))))
  (condition-case lossage
      (let ((inhibit-quit nil)
	    (case-fold-search isearch-case-fold-search))
	(if isearch-regexp (setq isearch-invalid-regexp nil))
	(setq isearch-within-brackets nil)
	(setq isearch-success
	      (funcall
	       (cond (isearch-word
		      (if isearch-forward
			  'word-search-forward 'word-search-backward))
		     ((or isearch-regexp
			  (and (boundp 'tcode-mode)
			       tcode-mode
			       tcode-isearch-enable-wrapped-search))
		      (if isearch-forward
			  're-search-forward 're-search-backward))
		     (t
		      (if isearch-forward 'search-forward 'search-backward)))
	       isearch-string nil t))
	(if isearch-success
	    (setq isearch-other-end
		  (if isearch-forward (match-beginning 0) (match-end 0)))))

    (quit (isearch-unread ?\C-g)
	  (setq isearch-success nil))

    (invalid-regexp
     (setq isearch-invalid-regexp (car (cdr lossage)))
     (setq isearch-within-brackets (string-match "\\`Unmatched \\["
						 isearch-invalid-regexp))
     (if (string-match
	  "\\`Premature \\|\\`Unmatched \\|\\`Invalid "
	  isearch-invalid-regexp)
	 (setq isearch-invalid-regexp "incomplete input")))
    (error
     ;; stack overflow in regexp search.
     (setq isearch-invalid-regexp (car (cdr lossage)))))

  (if isearch-success
      nil
    ;; Ding if failed this time after succeeding last time.
    (and (nth 3 (car isearch-cmds))
	 (ding))
    (goto-char (nth 2 (car isearch-cmds)))))

(defun tcode-isearch-remove-ignore-regexp (str)
  "ѿ `tcode-isearch-enable-wrapped-search'  nil ǤʤȤ
STR  `tcode-isearch-ignore-regexp' "
  (if (or (not tcode-isearch-enable-wrapped-search)
	  isearch-regexp)
      str
    (let (idx
	  (regexp-len (length tcode-isearch-ignore-regexp)))
      (while (setq idx (string-match
			(regexp-quote tcode-isearch-ignore-regexp)
			str))
	(setq str (concat (substring str 0 idx)
			  (substring str (+ idx regexp-len) nil))))
      str)))

(defun isearch-repeat (direction)
  ;; Utility for isearch-repeat-forward and -backward.
  (if (eq isearch-forward (eq direction 'forward))
      ;; C-s in forward or C-r in reverse.
      (if (equal isearch-string "")
	  ;; If search string is empty, use last one.
	  (setq isearch-string
		(or (if isearch-regexp
			(car regexp-search-ring)
		      (car search-ring))
		    "")
		isearch-message
		(mapconcat 'isearch-text-char-description
			   (tcode-isearch-remove-ignore-regexp isearch-string)
			   ""))
	;; If already have what to search for, repeat it.
	(or isearch-success
	    (progn
	      (goto-char (if isearch-forward (point-min) (point-max)))
	      (setq isearch-wrapped t))))
    ;; C-s in reverse or C-r in forward, change direction.
    (setq isearch-forward (not isearch-forward)))

  (setq isearch-barrier (point)) ; For subsequent \| if regexp.

  (if (equal isearch-string "")
      (setq isearch-success t)
    (if (and isearch-success (equal (match-end 0) (match-beginning 0)))
	;; If repeating a search that found
	;; an empty string, ensure we advance.
	(if (if isearch-forward (eobp) (bobp))
	    ;; If there's nowhere to advance to, fail (and wrap next time).
	    (progn
	      (setq isearch-success nil)
	      (ding))
	  (forward-char (if isearch-forward 1 -1))
	  (isearch-search))
      (isearch-search)))

  (isearch-push-state)
  (isearch-update))

(defun isearch-fep-mode ()
  (let ((command this-command)
	(isearch-fep-mode t)
	table str)
    (while isearch-fep-mode
      (setq table (assq command isearch-fep-table))
      (setq isearch-fep-prompt (funcall (car (cdr table))))
      (message "%s%s" isearch-fep-prompt (isearch-message))
      (if (eq command 'isearch-fep-string)    ;; \C-k
	  (progn
	    (setq str (funcall (nth 2 table)))
	    (setq isearch-fep-mode nil)
	    (isearch-process-search-string (car str) (cdr str)))
	(let* ((keys (read-key-sequence nil))
	       (current-command (key-binding keys t)))
	  (setq isearch-fep-mode (not (eq command current-command)))
	  (if isearch-fep-mode
	      (if (assq current-command isearch-fep-table)
		  (setq command current-command)
		(cond ((eq current-command 'isearch-printing-char)
		       (setq str (funcall (nth 2 table) keys))
		       (isearch-process-search-string (car str) (cdr str)))
		      ((or (eq current-command 'isearch-other-control-char)
			   (eq current-command 'isearch-other-meta-char))
		       (call-interactively current-command)
		       (setq isearch-fep-mode nil))
		      ((eq current-command 'isearch-exit)
		       (setq isearch-fep-mode nil)
		       (message "%s%s"
				(isearch-message-prefix) isearch-message))
		      (t
		       (call-interactively current-command))))
	    (setq isearch-fep-prompt nil)
	    (message "%s%s" (isearch-message-prefix) isearch-message)))))))

(defun tcode-isearch-make-string-for-wrapping (string)
  (let ((string-list (and string
			  (tcode-string-to-char-list string))))
    (if (and tcode-isearch-enable-wrapped-search
	     (not isearch-regexp)
	     string-list)
	(mapconcat
	 (function
	  (lambda (a)
	    (let ((s (char-to-string a)))
	      (cond ((and (string-match tcode-isearch-ignore-regexp s)
			  (> (match-end 0) 0))
		     tcode-isearch-ignore-regexp)
		    ((= (char-width a) 2)
		     (concat tcode-isearch-ignore-regexp s))
		    (t
		     (regexp-quote (char-to-string a)))))))
	 string-list
	 "")
      string)))

(defun isearch-fep-read-string ()
  (save-excursion
    (set-buffer (window-buffer (minibuffer-window)))
    (let* ((overriding-local-map nil)
	   (minibuffer-local-map (cons 'keymap minibuffer-local-map)))
      ;; Some program overwrites "\C-m"'s default binding.
      (define-key minibuffer-local-map "\C-m" 'exit-minibuffer)
      (define-key minibuffer-local-map "\C-s" 'exit-minibuffer)
      (define-key minibuffer-local-map "\C-r"
	'exit-minibuffer-and-isearch-backward)
      (condition-case condition
	  (let* ((string
		  (if tcode-isearch-active
		      (let ((minibuffer-setup-hook
			     (cons 'tcode-activate minibuffer-setup-hook)))
			(read-from-minibuffer (concat isearch-fep-prompt
						      (isearch-message))))
		    (read-from-minibuffer (concat isearch-fep-prompt
						  (isearch-message))))))
	    (cons (tcode-isearch-make-string-for-wrapping string) string))
	(quit
	 (isearch-abort))))))

(defun isearch-yank (chunk)
  ;; Helper for isearch-yank-word and isearch-yank-line
  ;; CHUNK should be word, line or kill.
  (let ((string (cond
                 ((eq chunk 'kill)
                  (current-kill 0))
                 (t
		  (save-excursion
		    (and (not isearch-forward) isearch-other-end
			 (goto-char isearch-other-end))
		    (buffer-substring
		     (point)
		     (save-excursion
		       (cond
			((eq chunk 'word)
			 (if (= (tcode-char-width
				      (tcode-char-after (point)))
				     2)
				  (forward-char 1)
				(forward-word 1)))
			((eq chunk 'line)
			 (end-of-line))
			(t		; for XEmacs
			 (funcall chunk)))
		       (point))))))))
    ;; Downcase the string if not supposed to case-fold yanked strings.
    (if (and isearch-case-fold-search
	     (eq 'not-yanks search-upper-case))
	(setq string (downcase string)))
    (if isearch-regexp (setq string (regexp-quote string)))
    (setq isearch-string (concat isearch-string
				 (tcode-isearch-make-string-for-wrapping
				  string))
	  isearch-message
	  (concat isearch-message
		  (mapconcat 'isearch-text-char-description
			     string ""))
	  ;; Don't move cursor in reverse search.
	  isearch-yank-flag t))
  (isearch-search-and-update))

;;;

(defun tcode-isearch-start-bushu ()
  "T-Code 󥯥󥿥륵 prefix ѴϤ롣"
  (tcode-bushu-init 2)
  (or (get-buffer tcode-bushu-buffer-name)
      (error "Bushu dictionary not ready."))
  (setq isearch-message (concat isearch-message ""))
  (isearch-push-state)
  (isearch-update))


(defun tcode-isearch-postfix-bushu ()
  "T-Code 󥯥󥿥륵  postfix Ѵ"
  (let ((p1 (string-match "..$" isearch-message))
	(p2 (string-match ".$"  isearch-message)))
    (if (null p1)
	(beep)
      (tcode-isearch-bushu-henkan (substring isearch-message p1 p2)
				  (substring isearch-message p2)))))


(defun tcode-isearch-bushu ()
  "isearch-messageʸĴ٤"
  (cond
   ((string-match "$" isearch-message)
    t)
   ((string-match ".$" isearch-message)
    (substring isearch-message (string-match ".$" isearch-message)))
   (t
    nil)))


(defun tcode-isearch-bushu-henkan-command ()
  "isearchѴϤ롣"
  (interactive)
  (if (not tcode-use-postfix-bushu-as-default)
      (tcode-isearch-start-bushu)
    (tcode-isearch-postfix-bushu)))


(defun tcode-isearch-init ()
  "T-Code 󥯥󥿥륵ν"
  (setq tcode-isearch-active (if (numberp tcode-isearch-start-state)
				 (if (zerop tcode-isearch-start-state) nil t)
			       (and (boundp 'tcode-mode)
				    tcode-mode)))
  (isearch-update))

(add-hook 'isearch-mode-hook 'tcode-isearch-init)


(defun tcode-isearch-read-string ()
  "󥯥󥿥륵ʸɤ߹ࡣ"
  (let* (overriding-terminal-local-map
	 (minibuffer-setup-hook (lambda ()
				  (tcode-activate tcode-mode)))
	 (string (read-string (concat "Isearch read: " isearch-message)
			      nil nil nil t)))
    (unless (string= string "")
      (tcode-isearch-process-string string nil))))


(defun tcode-isearch-prefix-mazegaki ()
  "󥯥󥿥륵ַθ򤼽ѴԤ"
  (let* (overriding-terminal-local-map
	 (minibuffer-setup-hook (lambda ()
				  (tcode-activate tcode-mode)
				  (tcode-start-fixed-mazegaki)))
	 (string (read-string (concat "Isearch read: " isearch-message)
			      nil nil nil t)))
    (unless (string= string "")
      (tcode-isearch-process-string string nil))))


(defun tcode-isearch-postfix-mazegaki ()
  "󥯥󥿥륵˸ַθ򤼽ѴԤ"
  (let ((orig-isearch-cmds isearch-cmds))
    (unwind-protect
	(let ((current-string isearch-message))
	  ;; clear isearch states
	  (while (cdr isearch-cmds)
	    (isearch-pop-state))
	  (let* (overriding-terminal-local-map
		 (minibuffer-setup-hook (lambda ()
					  (tcode-activate tcode-mode)
					  (tcode-mazegaki-start nil)))
		 (string (read-string "Isearch read: "
				      current-string nil nil t)))
	    (unless (string= string "")
	      (tcode-isearch-process-string string nil))))
      (setq isearch-cmds orig-isearch-cmds)
      (isearch-top-state))))

;;; tc-is19.el ends here