;;; tc-bushu.el --- bushu henkan on T-Code

;; Copyright (C) 1996, 97 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
;; Created: 10 Dec 1996
;; Version: $Id: tc-bushu.el,v 2.0.5.0 1998/08/22 06:56:40 kitajima Exp $
;; Keywords: wp

;; 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:

(require 'tc)

(defconst tcode-bushu-reverse-buffer-name " *bushu-reverse-dictionary*")

(defvar tcode-bushu-reverse-dictionary-name
  (concat tcode-data-directory "bushu.rev")
  "* հ󼭽Υѥ̾")


(defun tcode-bushu-init (level)
  "ѴνԤʤ
LEVELѿtcode-bushu-on-demand꾮äԤʤʤ"
  (interactive (list 999))
  (or (get-buffer tcode-bushu-buffer-name)
      (< level tcode-bushu-on-demand)
      (progn
	(tcode-read-bushu-dictionary)
	(run-hooks 'tcode-bushu-ready-hook))))

(defun tcode-bushu-search (str)
  "ߤΥХåեΡ STR ǻϤޤԤΤǽΤΤ򸫤Ĥ롣"
  (let ((min (point-min))
	(max (point-max))
	kouho)
    (or (catch 'found
	  (and (eobp)
	       (forward-line -1))
	  (while (< min max)
	    (cond ((string< (setq kouho
				  (buffer-substring (progn
						      (beginning-of-line)
						      (point))
						    (save-excursion
						      (end-of-line)
						      (point))))
			    str)
		   (forward-line 1)
		   (goto-char (/ (+ (setq min (point)) max) 2)))
		  ((string< str kouho)
		   (goto-char (/ (+ min (setq max (point))) 2)))
		  ((throw 'found t)))))
	(looking-at str))))

(defun tcode-read-bushu-dictionary (&optional force)
  "Ѵɤ߹"
  (interactive "P")
  (save-excursion
    (let ((dic-buf (set-buffer (get-buffer-create tcode-bushu-buffer-name)))
	  (rev-buf (get-buffer-create tcode-bushu-reverse-buffer-name)))
      (or (and (null force)
	       (> (buffer-size) 0))
	  (progn
	    (erase-buffer)
	    (message "󼭽ɤ߹...")
	    (insert-file-contents tcode-bushu-dictionary-name)

	    (if (file-newer-than-file-p tcode-bushu-dictionary-name
					tcode-bushu-reverse-dictionary-name)
		;; հ
		(let ((count 0)
		      character
		      component)
		  (while (not (eobp))
		    (message "հ(%d)..." count)
		    (setq count (1+ count)
			  component (buffer-substring
				     (point)
				     (progn (tcode-forward-char 2) (point)))
			  character (buffer-substring
				     (point)
				     (progn (tcode-forward-char 1) (point))))
		    (save-excursion
		      (set-buffer rev-buf)
		      (let ((entry (concat character component)))
			(or (tcode-bushu-search entry)
			    (insert entry ?\n))))
		    (forward-line 1))
		  (save-excursion
		    (set-buffer rev-buf)
		    (write-region (point-min) (point-max)
				  (expand-file-name
				   tcode-bushu-reverse-dictionary-name)))
		  (message "հ(%d)...λ" count))
	      (set-buffer rev-buf)
	      (erase-buffer)
	      (insert-file-contents tcode-bushu-reverse-dictionary-name))
	    (message "󼭽ɤ߹...λ"))))))


(defun tcode-bushu-lookup (str1 str2)
  (or (cdr (assoc str2 (get (intern-soft str1 tcode-stroke-table) 'bushu)))
      (save-excursion
	(set-buffer (get-buffer tcode-bushu-buffer-name))
	(let ((str (concat str1 str2)))
	  (tcode-bushu-search str)
	  (and (looking-at (concat "^" str "\\(.\\)"))
	       (let ((composed (buffer-substring (match-beginning 1)
						 (match-end 1))))
		 (put (intern str1 tcode-stroke-table)
		      'bushu
		      (cons (cons str2 composed)
			    (get (intern-soft str1 tcode-stroke-table)
				 'bushu)))
		 composed))))))

(defun tcode-bushu-reverse-lookup (str)
  (or (get (intern-soft str tcode-stroke-table) 'composition)
      (save-excursion
	(set-buffer (get-buffer tcode-bushu-reverse-buffer-name))
	(tcode-bushu-search str)
	(and (looking-at (concat "^" str "\\(.\\)\\(.\\)"))
	     (let ((elm (cons (buffer-substring (match-beginning 1)
						(match-end 1))
			      (buffer-substring (match-beginning 2)
						(match-end 2)))))
	       (put (intern str tcode-stroke-table) 'composition elm))))))

(defun tcode-start-bushu ()
  "ѴϤ"
  (tcode-bushu-init 2)
  (or (get-buffer tcode-bushu-buffer-name)
      (error "Bushu dictionary not ready."))
  (setq tcode-bushu-nest (1+ tcode-bushu-nest))
  (insert ""))

(defun tcode-end-bushu ()
  "¦Ѵλ"
  (setq tcode-bushu-nest (1- tcode-bushu-nest))
  (let ((line-beginning
	 (save-excursion (beginning-of-line)
			 (point))))
    (save-excursion
      (if (search-backward "" line-beginning t)
	  (delete-char 1)))))

(defun tcode-find-another-first-char (kanji another-kanji)
  "1ܤ KANJI ǤꡢĹ夬ľϲǽʻ롣"
  (save-excursion
    (set-buffer (get-buffer tcode-bushu-buffer-name))
    (tcode-bushu-search kanji)
    (catch 'found
      (let ((re (concat "^" kanji "\\(.\\)\\(.\\)"))
	    this-kanji)
	(while (looking-at re)
	  (setq this-kanji (buffer-substring (match-beginning 2)
					     (match-end 2)))
	  (and (tcode-stroke-for-char this-kanji)
	       (not (tcode-lookup-outset-sub this-kanji another-kanji))
	       (throw 'found this-kanji))
	  (forward-line 1))))))

(defun tcode-find-another-second-char (kanji another-kanji)
  "2ܤ KANJI ǤꡢĹ夬ľϲǽʻ롣"
  (save-excursion
    (set-buffer (get-buffer tcode-bushu-buffer-name))
    (goto-char (point-min))
    (catch 'found
      (let ((re (concat "^\\(.\\)" kanji "\\(.\\)"))
	    this-kanji)
	(while (re-search-forward re nil t)
	  (setq this-kanji (buffer-substring (match-beginning 2)
					     (match-end 2)))
	  (and (tcode-stroke-for-char this-kanji)
	       (not (tcode-lookup-outset-sub this-kanji another-kanji))
	       (throw 'found this-kanji)))))))

(defun tcode-decompose-char-indirect (kanji)
  "KANJI2Ĥʬ򤹤롣KANJI ľʬǤʤȤ롣
֤ͤ2Ĥλ cons 롣
ʬǤʤˤnil֤"
  (and (not (string= kanji 'N))
       (save-excursion
	 (set-buffer (get-buffer tcode-bushu-buffer-name))
	 (goto-char (point-min))
	 (let (1st 2nd 3rd can-direct-1st can-direct-2nd can-direct-3rd alist
		   (re (concat "^.?" kanji)))
	   (or (catch 'found
		 (while (re-search-forward re nil t)
		   (beginning-of-line)
		   (looking-at "^\\(.\\)\\(.\\)\\(.\\)")
		   (forward-line 1)
		   (setq 1st (buffer-substring (match-beginning 1)
					       (match-end 1))
			 2nd (buffer-substring (match-beginning 2)
					       (match-end 2))
			 3rd (buffer-substring (match-beginning 3)
					       (match-end 3))
			 can-direct-1st (tcode-stroke-for-char 1st)
			 can-direct-2nd (tcode-stroke-for-char 2nd)
			 can-direct-3rd (tcode-stroke-for-char 3rd))
		   (cond ((string= 1st kanji)
			  ;; ܤ KANJI
			  (and (not (string= 2nd kanji))
			       (not (string= 3rd kanji))
			       (not (tcode-lookup-outset-sub 2nd 3rd))
			       (cond ((and can-direct-2nd can-direct-3rd)
				      ;; ξľϤǤ
				      (throw 'found (cons 2nd 3rd)))
				     ((or (null alist)
					  can-direct-2nd can-direct-3rd)
				      (setq alist (cons 2nd 3rd))))))
			 ((string= 2nd kanji)
			  ;; ܤ KANJI
			  (and (not (string= 3rd kanji))
			       (not (tcode-lookup-outset-sub 1st 3rd))
			       (cond ((and can-direct-1st can-direct-3rd)
				      ;; ξľϤǤ
				      (throw 'found (cons 1st 3rd)))
				     ((or (null alist)
					  can-direct-1st can-direct-3rd)
				      (setq alist (cons 1st 3rd)))))))))
	       alist)))))

(defun tcode-decompose-char (kanji &optional for-help)
  "KANJI2Ĥʬ򤹤롣
֤ͤ2Ĥλ cons 롣
ʬǤʤˤnil֤"
  (tcode-bushu-init 2)
  (let ((sym (tcode-bushu-reverse-lookup kanji)))
    (if sym
	(if (and for-help
		 tcode-strict-help)
	    (let ((kanji1 (car sym))
		  (kanji2 (cdr sym))
		  ch)
	      (cond ((or (tcode-stroke-for-char kanji) ; ľϤǤ
			 (and (tcode-stroke-for-char kanji1)
			      (tcode-stroke-for-char kanji2))
			 (and (tcode-stroke-for-char
			       (setq kanji1
				     (tcode-outset-alternative-reverse
				      kanji1)))
			      (tcode-stroke-for-char
			       (setq kanji2
				     (tcode-outset-alternative-reverse
				      kanji2))))))
		    ;; ʸܤľϤǤʸܤǤʤ
		    ((and (tcode-stroke-for-char kanji1)
			  (not (tcode-stroke-for-char kanji2))
			  (cond ((string= kanji2 'N))
				((setq ch
				       (tcode-find-another-second-char
					kanji2 kanji1))
				 (setq kanji2 ch))
				((setq ch
				       (tcode-find-another-first-char
					kanji2 kanji1))
				 (setq kanji2 ch)))))
		    ;; ʸܤľϤǤưʸܤǤʤ
		    ((and (not (tcode-stroke-for-char kanji1))
			  (tcode-stroke-for-char kanji2)
			  (cond ((string= kanji1 'N))
				((setq ch
				       (tcode-find-another-first-char
					kanji1 kanji2))
				 (setq kanji1 ch))
				((setq ch
				       (tcode-find-another-second-char
					kanji1 kanji2))
				 (setq kanji1 ch)))))
		    ;; ξľϤǤʤ
		    ((or (let ((alist
				(tcode-decompose-char-indirect kanji)))
			   (and alist
				(setq kanji1 (car alist)
				      kanji2 (cdr alist)))))))
	      (cons kanji1 kanji2))
	  sym)
      (and for-help
	   tcode-strict-help
	   (tcode-decompose-char-indirect kanji)))))

(defun tcode-lookup-outset-sub (tchar-1 tchar-2)
  "TCHAR-1  TCHAR-2 ľȤ߹碌ƤǤ볰ܤ
Ĥʤäˤ nil ֤"
  (and tchar-1
       tchar-2
       (or (tcode-bushu-lookup tchar-1 tchar-2)
	   (tcode-bushu-lookup tchar-2 tchar-1))))

(defun tcode-outset-alternative-reverse (char)
  "EQCHAR ʸ CHAR ֤äˤʤ EQCHAR Ȥ֤
EQCHAR  CHAR ǤȤ NL + EQCHAR = CHAR Ƥ
ȤǤ롣"
  (save-excursion
    (set-buffer (get-buffer tcode-bushu-buffer-name))
    (tcode-bushu-search "N")
    (let (eqchar this-char)
      (or (catch 'found
	    (while (looking-at "^N\\(.\\)\\(.\\)")
	      (setq eqchar (buffer-substring
			    (match-beginning 1)
			    (match-end 1))
		    this-char (buffer-substring
			       (match-beginning 2)
			       (match-end 2)))
	      (and (string= this-char char)
		   (throw 'found eqchar))
	      (forward-line 1)))
	  char))))

(defun tcode-outset-alternative (char)
  "CHAR ʸ EQCHAR ֤äˤʤ CHAR Ȥ֤
CHAR ǤȤ NL + EQCHAR = CHAR Ƥ뤳ȤǤ롣"
  (let ((eqchar (tcode-decompose-char char)))
    (if (and eqchar (string= (car eqchar) 'N))
	(cdr eqchar)
      char)))

(defun tcode-lookup-outset (char-1 char-2)
  "CHAR-1  CHAR-2 Ȥ߹碌ƤǤ볰ܤ
Ĥʤäˤ nil ֤"
  (and char-1
       char-2
       (or (tcode-lookup-outset-sub (setq char-1 (tcode-2-to-1 char-1))
				    (setq char-2 (tcode-2-to-1 char-2)))
	   (let ((alt-char-1 (tcode-outset-alternative char-1))
		 (alt-char-2 (tcode-outset-alternative char-2)))
	     (prog1
		 (and (or (not (string= char-1 alt-char-1))
			  (not (string= char-2 alt-char-2)))
		      (tcode-lookup-outset-sub alt-char-1 alt-char-2))
	       (setq char-1 alt-char-1
		     char-2 alt-char-2)))
	   (let* ((decomposed-1 (tcode-decompose-char char-1))
		  (decomposed-2 (tcode-decompose-char char-2))
		  (tc11 (car decomposed-1))
		  (tc12 (cdr decomposed-1))
		  (tc21 (car decomposed-2))
		  (tc22 (cdr decomposed-2)))
	     (and (string= tc11 'N) (setq tc11 nil))
	     (and (string= tc12 'N) (setq tc12 nil))
	     (and (string= tc21 'N) (setq tc21 nil))
	     (and (string= tc22 'N) (setq tc22 nil))
	     (or (and (string= tc11 char-2)
		      (not (string= tc12 char-1))
		      (not (string= tc12 char-2))
		      tc12)		; subtraction
		 (and (string= tc12 char-2)
		      (not (string= tc11 char-1))
		      (not (string= tc11 char-2))
		      tc11)
		 (and (string= tc21 char-1)
		      (not (string= tc22 char-1))
		      (not (string= tc22 char-2))
		      tc22)
		 (and (string= tc22 char-1)
		      (not (string= tc21 char-1))
		      (not (string= tc21 char-2))
		      tc21)
		 (let ((loop '((char-1 . tc22) (char-2 . tc11)
			       ;; swaped by KITAJIMA     ^^^^
			       (char-1 . tc21) (char-2 . tc12)
			       (tc12 . tc22) (tc21 . tc12)
			       (tc11 . tc22) (tc21 . tc11))))
		   (catch 'found
		     (while loop
		       (let* ((i (car loop))
			      (i1 (eval (car i)))
			      (i2 (eval (cdr i)))
			      (res (and i1 i2
					(tcode-lookup-outset-sub i1 i2))))
			 (or (null res)
			     (string= res char-1)
			     (string= res char-2)
			     (throw 'found res)))
		       (setq loop (cdr loop)))))
		 ;; new subtraction
		 (and tc11 (string= tc11 tc21)
		      (not (string= tc12 char-1))
		      (not (string= tc12 char-2))
		      tc12)
		 (and tc11 (string= tc11 tc22)
		      (not (string= tc12 char-1))
		      (not (string= tc12 char-2))
		      tc12)
		 (and tc12 (string= tc12 tc21)
		      (not (string= tc11 char-1))
		      (not (string= tc11 char-2))
		      tc11)
		 (and tc12 (string= tc12 tc22)
		      (not (string= tc11 char-1))
		      (not (string= tc11 char-2))
		      tc11))))))

(defun tcode-compose-chars ()
  "ݥȤʸ"
  (interactive "*")
  (tcode-bushu-init 3)
  (let* ((p (point))
	 (prev-char (tcode-get-prev-nonspace))
	 (prev-prev-char (tcode-get-prev-nonspace))
	 (kanji (tcode-lookup-outset prev-prev-char prev-char))
	 (p2 (point)))
    (goto-char p)
    (if kanji
	(progn
	  (setq tcode-bushu-occurrence (1+ tcode-bushu-occurrence))
	  (delete-region p2 p)
	  (insert kanji)
	  (and tcode-auto-help
	       (tcode-display-direct-stroke kanji)
	       (tcode-auto-remove-help-char))
	  (setq tcode-help-char kanji))
      (beep)
      (message ""))))

(defun tcode-bushu-henkan ()
  "Ѵ򳫻Ϥ롣"
  (interactive)
  (if tcode-use-postfix-bushu-as-default
      (tcode-compose-chars)
    (tcode-start-bushu)))

(defun tcode-bushu-another-henkan ()
  "`tcode-use-postfix-bushu-as-default' ȤϵդѴ򳫻Ϥ롣"
  (interactive)
  (if tcode-use-postfix-bushu-as-default
      (tcode-start-bushu)
    (tcode-compose-chars)))

(provide 'tc-bushu)

;;; tc-bushu.el ends here