;;; egg-fence-abbrev.el 0.1
;; Copyright (C) 2000,2001
;; Hideyuki ENDO <endo-h@remus.dti.ne.jp>

;; Version: $Id: egg-fence-abbrev.el,v 1.6 2001/03/29 19:08:50 endo-h Exp $
;; Last Modified: $Date: 2001/03/29 19:08:50 $

;; 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 this program; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

;; egg-fence-abbrevは、EGGのfence-modeで入力の補完を行なうための
;; プログラムです。
;; 過去に入力したフレーズを記憶し、頭の何文字かを入力したあと
;; TAB keyを押して、補完を行なうことができます。
;;
;; 実験的なものです。というのは、機能や仕様に関して現在の状態がベス
;; トなのか定かではないものの、とりあえず実装しやすいように実装し
;; てみたと云うプログラムだからです。
;; ちなみに現在、辞書検索をバックエンドのプログラムに任せた版を作
;; 成中です。
;;
;; mule2.3+EGG3.09 + (Wnn4.2/FreeWnn)で開発しました(^◇^;)。
;;
;; 使用法:
;;   たとえば一度:
;;	|はれたひはいぬをあらおう|
;;   と入力し変換し確定します。すると次回からは
;;	|は|
;;   と入力してTAB keyを押すことで、
;;	|はれたひはいぬをあらおう|
;;   とfenceに入ります。これは自分で打ち込んだのと同じ状態なので、
;;   ここから変換や編集などができます。
;;   さらにTab keyを押してゆくと、長さが変わったり他の候補が出たり
;;   します。
;;   C-gを押して補完した部分のキャンセルができます。
;;
;; 設定:
;;   まずはegg-fence-abbrev.elをelispのパスの通っているところに置
;;   いてください。
;;   EGGを起動する時に一緒に起動すると良いので、~/.eggrcに
;;
;;	(load "egg-fence-abbrev")
;;
;;   と書いておくと使えるようになります。~/.emacsに書いておいても
;;   良いでしょうけど。
;;
;; メモ:
;;   入力したフレーズは、" *egg-fence-abbrev*" と云う名前の辞書バ
;;   ッファに保存されています。まあ眺めてみてください。


(if window-system
    (define-key fence-mode-map [t] 'egg-fence-abbrev)
  (define-key fence-mode-map "\t" 'egg-fence-abbrev))
(define-key fence-mode-map "\C-g" 'efa-cancel-input)

(add-hook 'egg:henkan-end-hook 'efa-log)
;(remove-hook 'egg:henkan-end-hook 'efa-log)

(add-hook 'egg:close-wnn-hook 'efa-save)

; これはadd-hookは使えない
(setq egg-exit-hook 'efa-log-wo-henkan)

(defvar efa-minlen 4
  "*記録する文字数の下限")

(defvar efa-dic "~/.efa.dic"
  "*egg-fence-abbrev用辞書")

(defvar efa-save-entries 20000
  "*ファイルにセーブするエントリ数")

(defvar efa-search-entries 5000
  "*確定時にサーチを行なうエントリ数")

(defvar efa-search-limit 150000
  "*確定時にサーチを行なうポジションの既定値")

(setq efa-eff-minlen (* 2 efa-minlen))

(defvar efa-buffer " *egg-fence-abbrev*"
  "egg-fence-abbrevの辞書バッファ")

(defvar efa-head-mark "==HEAD MARK=="
  "ロードした位置を示すためのマーク")

(defvar efa-dic-modify-time nil
  "辞書の最終変更時間")

(defvar efa-orig-pattern ""
  "オリジナルキーから生成した検索パターン")

(defvar efa-orig-key ""
  "オリジナルのキー")

(defvar efa-prev-cand-orig ""
  "前回の候補のオリジナル")

(defvar efa-whole-entry nil
  "現在読んでいる候補がエントリ全体か否かのフラグ")

(defvar efa-in-flag nil
  "efaの中に入っているか否かのフラグ")

(defvar efa-prev-match-point nil
  "どこまで検索したか憶えている変数")

(defun egg-fence-abbrev ()
  (interactive)
  (let (abbrev)
    (setq key (buffer-substring egg:*region-start* egg:*region-end*))
;    (message key)
    (setq abbrev (efa-search key))
    (delete-region egg:*region-start* egg:*region-end*)
    (insert abbrev)))

(defun efa-init ()
  (let (moved)
    (set-buffer (get-buffer-create efa-buffer))
    (buffer-enable-undo)
    (setq case-fold-search nil)		;Case Sensitiveにする
    (if (file-readable-p efa-dic)
	(progn
	  (setq efa-dic-modify-time (nth 5 (file-attributes efa-dic)))
	  (setq file-coding-system *euc-japan*)
	  (insert-file-contents efa-dic)
	  (goto-char (point-min))
	  (insert (concat efa-head-mark "\n"))
	  (setq moved (- efa-search-entries (goto-line efa-search-entries)))
	  (setq efa-search-limit (* (/ (point) moved) efa-search-entries))))
    (goto-char (point-min))))

; 処理を途中で中断 (C-gで呼ばれる)
(defun efa-cancel-input ()
  (interactive)
  (if efa-in-flag
      (progn
	(setq efa-in-flag nil)
	(delete-region egg:*region-start* egg:*region-end*)
;	(ding)
	(insert efa-orig-key))
    (progn
      (delete-region egg:*region-start* egg:*region-end*)
      (fence-exit-mode))))

; 辞書の同期を行なう
(defun efa-sync ()
  (interactive)
  (efa-save t))

(defun efa-save (&optional sync)
  (interactive)
  (let* ((dic-tmp (concat efa-dic ".tmp"))
	 (dic-modify-time (nth 5 (file-attributes efa-dic)))
	 (updatep (equal efa-dic-modify-time dic-modify-time)))
    (if (get-buffer efa-buffer)
	(progn
	  (if updatep
	      (progn		; 辞書ファイルは更新されていない。
		(save-excursion	; バッファ全体をセーブする
		  (set-buffer efa-buffer)
		  (buffer-disable-undo)
		  (goto-char (point-min))
		  ;空行とhead-markを消す
		  (flush-lines (concat "^$\\|" efa-head-mark))
		  (buffer-enable-undo)
		  (goto-line (1+ efa-save-entries))
		  (write-region 1 1 dic-tmp nil 0)
		  (set-file-modes dic-tmp 384)
		  (write-region  (point-min) (point) dic-tmp nil 0)))
	    (let (end-position)	; 辞書ファイルは更新されている
	      (save-excursion	; head-markまでを先頭に追加する
		(set-buffer efa-buffer)
		(buffer-disable-undo)
		(goto-char (point-min))
		(flush-lines "^$")
		(or (prog1	; head-markまで
			(search-forward efa-head-mark nil t)
		      (forward-line 0)
		      (kill-line 1)
		      (setq end-position (match-beginning 0)))
		    (prog1	; head-markがない
			(goto-line efa-save-entries)
		      (setq end-position (point))))
		(write-region 1 1 dic-tmp nil 0)
		(set-file-modes dic-tmp 384)
		(write-region (point-min) end-position dic-tmp t 0)
		(call-process "sh" nil nil nil "-c"
			      (concat "cat " efa-dic " >> " dic-tmp))
		(if sync
		    (progn
		      (erase-buffer)
		      (insert-file-contents dic-tmp)))
		(buffer-enable-undo))))
	  (if (file-exists-p efa-dic)
	      (rename-file efa-dic (concat efa-dic ".old") t))
	  (rename-file dic-tmp efa-dic t)
	  (if (or sync updatep)
	      (setq efa-dic-modify-time (nth 5 (file-attributes efa-dic))))
	  (save-excursion
	    (set-buffer efa-buffer)
	    (goto-char (point-min))
	    (flush-lines efa-head-mark)
	    (insert (concat efa-head-mark "\n")))))))


(defun efa-log-wo-henkan (start end)
  (let ((count 0) (count-cand 0)
	cand match)
    (and (not (equal start end))
	 (progn
	   (setq cand (efa-encode (buffer-substring start end)))
	   (string-match "^\\ca*$" cand))
	 (> (efa-chars-in-string cand) 1)	;とりあえず1文字は登録しない
	 (progn
	   (setq cand (concat "/" cand "-"))
	   (save-excursion
	     (efa-set-buffer-init)
	     (goto-char (point-min))
	     (setq key (concat "^" cand "\\(\t[0-9]+\\)?$"))
	     (and (re-search-forward key efa-search-limit t)
		  (progn
		    (setq match 
			  (buffer-substring (match-beginning 0)
					    (progn (end-of-line) (point))))
		    (forward-line 0)	;行頭へ
;		    (kill-line 1)
		    (kill-line nil)
		    (if (string-match "[0-9]+$" match)
			(setq count-cand 
			      (string-to-number 
			       (substring match (match-beginning 0)))))
		    (setq count (1+ count-cand))))
	     (goto-char (point-min))
	     (insert (concat cand (if (> count 0)
				      (format "\t%d" count)) "\n")))))))

(defun efa-log ()
  (let* ((max (wnn-server-bunsetu-suu))
	 (count 0) (top-count 0) (count-cand 0)
	 i yomis yomi key match top result)
    (setq i (1- max))
    (while (>= i 0)
      (setq yomis (cons (efa-encode (nth 1 (wnn-server-inspect i))) yomis))
      (setq i (1- i)))
    (setq i 0)
    (while (< i max)
      (setq yomi (concat yomi "/" (nth i yomis)))
      (setq i (1+ i)))
    (setq yomi (efa-formalize-yomi yomi))
    (if (and (not (string= efa-prev-cand-orig ""))
	     (string-match (format "^%s.+" efa-prev-cand-orig) yomi))
	(setq top efa-prev-cand-orig))
    (if (efa-registerp yomi)		; 登録するか?
	(save-excursion
	  (efa-set-buffer-init)
	  (goto-char (point-min))
	  (setq key (efa-register-pattern yomis top))
;	  (message "key[%s]" key)
	  (while (re-search-forward key efa-search-limit t) ; マッチした
	    (setq match (buffer-substring (match-beginning 0)
					  (progn (end-of-line) (point))))
	    (forward-line 0)	;行頭へ
	    (kill-line nil)
;	    (ding)
	    (if (string-match "[0-9]+$" match)
		(setq count-cand (string-to-number 
				  (substring match (match-beginning 0)))))
;	    (message "yomi[%s]t[%s]m[%s]" key top match)
	    (if (string-match 
		 (format "^%s\\(\t[0-9]+\\)?$" top) match)
		(setq top-count (1+ count-cand))
	      (setq count (1+ count-cand))))
	  (goto-char (point-min))
	  (if top 
	      (setq result (concat top (if (> top-count 0)
					   (format "\t%d" top-count)) "\n")))
	  (insert (concat result yomi (if (> count 0)
					  (format "\t%d" count)) "\n"))))))

(defun efa-set-buffer-init ()
  (if (get-buffer efa-buffer)
      (set-buffer efa-buffer)
    (efa-init)))

;; 登録を行なうか判定
(defun efa-registerp (yomi)
  (or (<= efa-eff-minlen (efa-chars-in-string yomi))
      (<= efa-minlen (efa-chars-in-string (efa-remove-delimiter yomi)))))

;; デリミタを削除する
(defun efa-remove-delimiter (yomi)
  (let ((start 0) (plain-yomi ""))
    (while (string-match "[^\-/]+" yomi start)
      (setq plain-yomi 
	    (concat plain-yomi 
		    (substring yomi (match-beginning 0) (match-end 0))))
      (setq start (match-end 0)))
    plain-yomi))

;; "+" を "-" に変換する
(defun efa-formalize-yomi (yomi)
  (let ((start 0) (result ""))
    (while (string-match "+" yomi start)
      (setq result 
	    (concat result (substring yomi start (match-beginning 0)) "-"))
      (setq start (match-end 0)))
    (setq result (concat result (substring yomi start)))
    result))

;; efa-searchによる検索のパターンを生成する  
(defun efa-search-pattern (key)
  (let ((start 0) (pattern "/[-]?"))
    (while (string-match "." key start)
      (setq pattern
	    (concat pattern 
		    (substring key (match-beginning 0) (match-end 0))
		    "[\-/]*"))
      (setq start (match-end 0)))
;    (setq pattern (concat pattern "[^-\t]+$"))
    pattern))

;; 登録時の検索パターンを生成する
(defun efa-register-pattern (yomis top)
  (let ((len (length yomis)) 
	(i 1)
	yomi)
    (setq yomi (concat "/" (efa-formalize-yomi (nth 0 yomis))))
    (while (< i len)
      (if (and (= i (1- len))
	       (not (efa-registerp (nth i yomis))))
	  (setq yomi (concat yomi "/" (efa-formalize-yomi (nth i yomis))))
	(setq yomi (concat "\\(" yomi "\\)?/" 
			   (efa-formalize-yomi (nth i yomis)))))
      (setq i (1+ i)))
    (if top
	(format "^\\(%s\\|%s\\)\\(\t[0-9]+\\)?$" top yomi)
      (format "^%s\\(\t[0-9]+\\)?$" yomi))))

(defvar efa-phash-size 257
  "既出hash表のサイズ")

(setq efa-phash-table (make-vector efa-phash-size nil))

(defvar efa-past-top 0
  "keyの長さ")

(defun efa-past-hash (str &optional top)
  (let ((len (length str)))
    (if (not top)
	(setq top efa-past-top))
    (% (+ (* 53 len (sref str (1- len))) 
	  (sref str efa-past-top)) efa-phash-size)))

(defun efa-pastp (str)
  (let (list)
    (setq list (aref efa-phash-table (efa-past-hash str)))
    (if list
	(efa-pastp-1 str list))))

(defun efa-pastp-1 (str list)
  (let (find)
    (while (and (not find) list)
      (if (string= str (car list))
	  (setq find t)
	(setq list (cdr list))))
    find))

;; 既出テーブルに追加する
(defun efa-add-past-list (str)
  (let (hash)
    (setq hash (efa-past-hash str))
    (aset efa-phash-table hash 
	  (nconc (list str) (aref efa-phash-table hash)))))

;; 既出テーブルをクリアする
(defun efa-clear-past-list ()
  (fillarray efa-phash-table nil))

;; 既出
(defun efa-init-past-list (key)
  (setq efa-past-top (length key))
  (efa-clear-past-list))


;; サーチを行なう
(defun efa-search (key)
  (interactive (list (read-current-its-string "よみ?: ")))
  (let ((prev-cand (efa-remove-delimiter efa-prev-cand-orig))
	pattern cand cand-orig cand-cand start-point fail contp pastp)
    (setq key (efa-encode key))
    (setq contp (string= prev-cand key))
    (if contp		;前回の出力がkey = 前回と同じ検索パターン
	(progn
;	  (message "same pattern")
	  (setq start-point efa-prev-match-point
		pattern efa-orig-pattern))
      (progn				;新しい検索パターン
;	(message "new pattern")
	(efa-init-past-list key)
	(setq start-point (point-min)
	      pattern (efa-search-pattern key)
	      efa-prev-cand-orig ""
	      efa-orig-key key
	      efa-orig-pattern pattern)))
    (while (and (not cand) (not fail))
      (or (and contp	;候補リストが空でない
	       (setq cand-orig (from-prev-cand-orig efa-prev-cand-orig))
	       (setq cand-cand (efa-remove-delimiter cand-orig))
	       (< (length efa-orig-key) (length cand-cand)))
	  (and (setq cand-orig (from-buffer-search pattern start-point))
	       (setq cand-cand (efa-remove-delimiter cand-orig))))
;       (message "[%s][%s/%d][%s/%d]" cand-orig cand-cand (length cand-cand)
;	       efa-orig-key (length efa-orig-key))
      (if cand-orig
	  (progn			;候補があった
	    (if (< (length efa-orig-key) (length cand-cand))
		(progn
		  (setq pastp (efa-pastp cand-cand))
		  (if (and (not pastp)
			   (< (length efa-orig-key) (length cand-cand)))
		      (progn		;初出
			(setq efa-in-flag t)
			(setq cand cand-cand)
			(setq efa-prev-cand-orig cand-orig))
		    (progn		;既出
		      (if (and pastp efa-whole-entry)
			  (efa-delete-entry cand-orig))
		      (setq efa-prev-cand-orig "")
		      (setq start-point efa-prev-match-point))))
	      (progn
		(setq efa-prev-cand-orig "")
		(setq start-point efa-prev-match-point))))
	(progn				;候補がない
	  (efa-clear-past-list)
	  (setq efa-in-flag nil)
	  (setq fail t)
	  (setq cand efa-orig-key))))
    (if (not fail)
	(efa-add-past-list cand))
    (efa-decode cand)))

(defun efa-delete-entry (cand-orig)
  (let (begin end entry)
    (save-excursion
      (efa-set-buffer-init)
      (setq end (progn (end-of-line) (point))
	    begin (progn (beginning-of-line) (point)))
      (setq entry (buffer-substring begin end))
      (if (string-match "\t.*$" entry)
	  (setq entry (substring entry 0 (match-beginning 0))))
;      (message "match?[%s][%s]" cand-orig entry)
      (if (string= cand-orig entry)
	  (progn
;	    (message "match![%s][%s]" cand-orig entry)
	    (ding)
	    (kill-line nil)
	    (setq efa-prev-match-point (point)))))))

(defun from-buffer-search (pattern start-point)
  (let (cand-orig match-point)
    (save-excursion
      (efa-set-buffer-init)
;      (message "buffer search [%s][%s][%s]" pattern (point) start-point)
      (goto-char start-point)
      (and (re-search-forward pattern nil t)
	   (progn
	     (setq match-point (match-beginning 0))
	     (setq efa-prev-match-point (1+ (match-beginning 0)))
	     (setq cand-orig (buffer-substring (match-beginning 0)
					       (progn (end-of-line) (point))))
;	     (setq efa-prev-match-point (point))
	     (if (string-match "\t.*$" cand-orig)
		 (setq cand-orig 
		       (substring cand-orig 0 (match-beginning 0))))))
      (if (eq match-point (progn (beginning-of-line) (point)))
	  (setq efa-whole-entry t)
	(setq efa-whole-entry nil)))
    cand-orig))

(defun from-prev-cand-orig (prev-cand-orig)
  (setq efa-whole-entry nil)
  (or (and (or (string-match "^\\(.+-\\)[^/]+$" prev-cand-orig)	;"-"
	       (string-match "^\\(.+\\)/.+$" prev-cand-orig))	;"/"
	   (substring prev-cand-orig (match-beginning 1) (match-end 1)))))

(defun efa-chars-in-string (str)
  (let ((len (length str))
	(idx 0)
	(nchars 0))
    (while (< idx len)
      (setq nchars (1+ nchars))
      (setq idx (+ idx (char-bytes (sref str idx)))))
  nchars))

;; delimiterをencodeする
(defun efa-encode (str)
  (let ((start 0) (result "") match)
    (while (string-match "[\-/&]" str start)
      (setq match (substring str (match-beginning 0)(match-end 0)))
      (setq result (concat result 
			   (substring str start (match-beginning 0))
			   (cond ((string= "-" match) "&#45;")
				 ((string= "/" match) "&#47;")
				 ((string= "&" match) "&#38;"))))
      (setq start (match-end 0)))
    (setq result (concat result (substring str start)))
    result))

;; delimiterをdecodeする
(defun efa-decode (str)
  (let ((start 0) (result "") match)
    (while (string-match "&#\\(45\\|47\\|38\\);" str start)
      (setq match (substring str (match-beginning 0)(match-end 0)))
      (setq result (concat result
			   (substring str start (match-beginning 0))
			   (cond ((string= "&#45;" match) "-")
				 ((string= "&#47;" match) "/")
				 ((string= "&#38;" match) "&"))))
      (setq start (match-end 0)))
    (setq result (concat result (substring str start)))
    result))

;; EOF