;; -*-byte-compile-dynamic: t;-*-
;; -*- byte-compile-dynamic-docstring: t;-*-
;;; skk-study.el --- SKK 学習効果提供プログラム
;; Copyright (C) 1999 Mikio Nakajima <minakaji@osaka.email.ne.jp>

;; Author: Mikio Nakajima <minakaji@osaka.email.ne.jp>
;; Maintainer: Mikio Nakajima <minakaji@osaka.email.ne.jp>
;; Version: $Id: skk-study.el,v 1.1.2.3 1999/11/10 13:02:39 minakaji Exp $
;; Keywords: japanese
;; Created: Apr. 11, 1999
;; Last Modified: $Date: 1999/11/10 13:02:39 $

;; This file is part of Daredevil SKK.

;; Daredevil SKK 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 versions 2, or (at your option)
;; any later version.

;; Daredevil SKK 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 Daredevil SKK, see the file COPYING.  If not, write to the Free
;; Software Foundation Inc., 59 Temple Place - Suite 330, Boston,
;; MA 02111-1307, USA.

;;; Commentary:
;;
;; ある単語を変換した場合に、直前に変換した語を関連語として登録しておき、再度そ
;; の単語の変換を行なったときに登録した関連語が辞書にあればそれを優先して出力す
;; る単純な学習効果を提供するプログラムです。
;;
;; 昔 SKK ML で話題になった単語の属性の保存のために、skk-attr.el を作りました
;; が、機能を欲張りすぎてものになりませんでした。直前の変換との関連性を保存するた
;; めだけに機能を絞って再構成したのがこのプログラムです。

;; <How to work>
;;
;; XEmacs で SKK をパッケージインストールした場合は、.emacs に
;;
;;   (setq skk-search-end-function 'skk-study-search)
;;   (setq skk-update-end-function 'skk-study-update)
;;
;; と書くだけで十分です。それ以外の方は、
;;
;;   (add-hook 'skk-load-hook (function (lambda () (require 'skk-study))))
;;
;; などと書いて下さい。

;; <DATA STRUCTURE (SKK-STUDY-ALIST)>
;;
;; ((okuri-ari . (("現在の HENKAN-KEY" . ((("直前の HENKAN-KEY" . "直前の漢字") . ("HENKAN-KEY を見出し語とする関連語" ...))
;;                                        ... ))))
;;  (okuri-nasi . (("現在の HENKAN-KEY" . ((("直前の HENKAN-KEY" . "直前の漢字") . ("HENKAN-KEY を見出し語とする関連語" ...))
;;                                         ... )))))
;;
;;  o examples
;;
;; ((okuri-ari .
;;           (("きr" . ((("ふく" . "服") . ("着"))
;;                      (("き" . "木") . ("切"))
;;                      (("えん" . "縁") . ("切")) ))
;;            ("なk" . ((("こども" . "子供") . ("泣"))
;;                      (("ことり" . "小鳥") . ("鳴")) ))
;;            ("かk" . ((("かみ" . "紙") . ("書")) (("ひんかく" . "品格") . ("欠")))) )
;;           ... )
;;  (okuri-nasi .
;;            (("かみ" . ((("きr" . "切") . ("紙"))))
;;             ... )))
;;
;; <TODO>
;;

;;; Code:
(eval-when-compile (require 'cl) (require 'ring) (require 'skk-macs)
		   (require 'skk-vars) )

;;;###autoload
(defgroup skk-study nil "SKK study related customization."
  :prefix "skk-study-"
  :group 'skk )

;;; user variables.
(defcustom skk-study-file (convert-standard-filename "~/.skk-study")
  "*学習結果を保存するファイル。"
  :type 'file
  :group 'skk-study )

(defcustom skk-study-backup-file (convert-standard-filename "~/.skk-study.BAK" )
  "*学習結果を保存するバックアップファイル。"
  :type 'file
  :group 'skk-study )

(defcustom skk-study-associates-number 3
  "*保存する関連語の数。"
  :type 'integer
  :group 'skk-study )

(defcustom skk-study-sort-saving t
  "*Non-nil であれば学習結果をソートしてセーブする。"
  :type 'boolean
  :group 'skk-study )

(defcustom skk-study-check-alist-format t
  "*Non-nil であれば、学習結果の読み込み時に連想リストのフォーマットをチェックする。"
  :type 'boolean
  :group 'skk-study )
	 
(defcustom skk-study-search-times 3
  "*現在の変換キーに対する関連変換キーをいくつまで遡って検索するか。"
  :type 'integer
  :group 'skk-study )

;;; system internal variables and constants.
;; global variable
(defconst skk-search-end-function 'skk-study-search)
(defconst skk-update-end-function 'skk-study-update)

(defconst skk-study-file-format-version 0.2)
(defvar skk-kakutei-end-function nil)
(defvar skk-study-alist nil)
(defvar skk-study-data-ring nil
  "ring.el を使った直前の skk-study-search-times 個分の変換キーと確定語データ。
具体的には、下記のような構造になっている。

\(2 3 . [\(\"こうぞう\" . \"構造\"\) \(\"ぐたいてき\" . \"具体的\"\) \(\"かき\" . \"下記\"\)]\)" )

(defvar skk-study-last-save nil)
(defvar skk-study-last-read nil)

;;;; inline functions.
(defsubst skk-study-get-last-henkan-data (index)
  (and (> (ring-length skk-study-data-ring) index)
       (ring-ref skk-study-data-ring index) ))

;;;###autoload
(defun skk-study-search (henkan-buffer midasi okurigana entry)
  (or skk-study-data-ring 
      (setq skk-study-data-ring (make-ring skk-study-search-times)) )
  (if (or (null entry)
	  ;; list of single element.
	  (null (cdr entry)) )
      nil
    (with-current-buffer henkan-buffer
      (if (or skk-study-alist (skk-study-read))
	  ;; (("きr" . ((("ふく" . "服") . ("着")) (("き" . "木") . ("切"))))
	  ;;  ("なk" . ((("こども" . "子供") . ("泣")))) )
	    
	  (let ((target-alist
		 (cdr (assoc midasi
			     (cdr (assq (cond ((or skk-okuri-char skk-henkan-okurigana)
					       'okuri-ari )
					      (t 'okuri-nasi) )
					skk-study-alist ))))))
	    (if target-alist
		(setq entry (skk-study-search-1 target-alist midasi okurigana entry)) )))))
  entry )

(defun skk-study-search-1 (target-alist midasi okurigana entry)
  (do ((index 0 (1+ index))
       (times skk-study-search-times (1- times))
       last-data associates e modified )
      ((or modified (= times 0)) entry)
    (and 
     (setq last-data (skk-study-get-last-henkan-data index))
     ;; ((("ふく" . "服") . ("着")) (("き" . "木") . ("切")))
     ;; ("着")
     (setq associates (cdr (assoc last-data target-alist)))
     (setq associates (reverse associates))
     (setq modified t)
     (while (setq e (car associates))
       (setq entry (cons e (delete e entry))
	     associates (cdr associates) )))))

;;;###autoload
(defun skk-study-update (henkan-buffer midasi okurigana word purge)
  (or skk-study-data-ring 
      (setq skk-study-data-ring (make-ring skk-study-search-times)) )
  (with-current-buffer henkan-buffer
    (let ((inhibit-quit t)
	  (last-data (if (not (ring-empty-p skk-study-data-ring))
			 (ring-ref skk-study-data-ring 0) ))
	  grandpa papa baby )
      (if (and (or skk-study-alist (skk-study-read))
	       midasi word last-data
	       (not (or (string= midasi "") (string= word "")
			(and (string= midasi (car last-data))
			     (string= word (cdr last-data)) ))))
	  (progn
	    (setq grandpa (assq (cond ((or skk-okuri-char skk-henkan-okurigana)
				       'okuri-ari )
				      (t 'okuri-nasi) )
				skk-study-alist )
		  ;; ((("ふく" . "服") . ("着")) (("き" . "木") . ("切")))
		  papa (assoc midasi (cdr grandpa)) )
	    (cond (
		   ;; car に見出し語を持つ cell がない
		   (not (or papa purge))
		   (setcdr grandpa
			   (nconc
			    (list (cons midasi (list (cons last-data (list word)))))
			    (cdr grandpa) )))
		  ;; 見出し語から始まる cell はあるが、cdr に (last-key . last-word) を
		  ;; キーにした cell がない。
		  ((not (or
			 ;; (("ふく" . "服") . ("着"))
			 (setq baby (assoc last-data (cdr papa)))
			 purge ))
		   (setcdr papa (cons (cons last-data (list word)) (cdr papa))) )
		  ;; 見出し語をキーとした既存の cell 構造ができあがっているので、関連語だけ
		  ;; アップデートする。
		  ((not purge)
		   ;; ring データの方がもっと効率的か？  でもここの部分のデータのアップデート
		   ;; が効率良くできない。
		   (setcdr baby (cons word (delete word (cdr baby))))
		   (if (> (1- (length (cdr baby))) skk-study-associates-number)
		       (skk-study-chomp (cdr baby) (1- skk-study-associates-number)) ))
		  (t (setcdr grandpa (delq baby (cdr grandpa)))) ))))))

;;;###autoload
(defun skk-study-save (&optional nomsg)
  "skk-study-file に学習結果を保存する."
  (interactive "P")
  (let ((inhibit-quit t)
	(last-time
	 (nth 5 (file-attributes (expand-file-name skk-study-file))) )
	e )
    (if (or (and (null skk-study-alist) (not nomsg))
	    (not skk-study-last-read)
	    (and skk-study-last-save 
		 (skk-study-time-lessp
		  skk-study-last-read skk-study-last-save )))
	(progn
	  (skk-message "SKK の学習結果をセーブする必要はありません"
		       "No SKK study need saving" )
	  (sit-for 1) )
      (if (not nomsg)
	  (skk-message "%s に SKK の学習結果をセーブしています..."
		       "Saving SKK study to %s..." skk-study-file ))
      (and skk-study-backup-file
	   (file-exists-p (expand-file-name skk-study-file))
	   (copy-file (expand-file-name skk-study-file)
		      (expand-file-name skk-study-backup-file)
		      'ok-if-already-exists 'keep-date ))
      (with-temp-buffer
	(insert
	 (format ";;; skk-study-file format version %s\n"
		 skk-study-file-format-version ))
	(if (not skk-study-sort-saving)
	    nil
	  ;; sort is not necessary, but make an alist rather readable.
	  (setq e (assq 'okuri-ari skk-study-alist))
	  (setcdr e (sort (cdr e) (function (lambda (a b) (string< (car a) (car b))))))
	  (setq e (assq 'okuri-nasi skk-study-alist))
	  (setcdr e (sort (cdr e) (function (lambda (a b) (string< (car a) (car b)))))) )
	(skk-study-prin1 skk-study-alist (current-buffer))
	(write-region-as-coding-system
	 (cond ((and skk-jisyo-code
		     (or (coding-system-p skk-jisyo-code)
			 (and (fboundp 'find-coding-system)
			      (find-coding-system skk-jisyo-code) )))
		skk-jisyo-code )
	       ((and skk-jisyo-code (stringp skk-jisyo-code))
		(cdr (assoc skk-jisyo-code skk-coding-system-alist)) )
	       (t (cdr (assoc "euc" skk-coding-system-alist))) )
	 (point-min) (point-max) skk-study-file ))
      (setq skk-study-last-save (current-time))
      (if (not nomsg)
	  (progn
	    (skk-message "%s に SKK 学習結果をセーブしています...完了！"
			 "Saving SKK study to %s...done" skk-study-file )
	    (sit-for 1)
	    (message "") )))))

;;;###autoload
(defun skk-study-read (&optional nomsg force)
  "skk-study-file から学習結果を読み込む。
オプショナル引数の FORCE が non-nil であれば、破棄の確認をしない。"
  (interactive "P")
  (skk-create-file
   skk-study-file
   (if (not nomsg)
       (if skk-japanese-message-and-error
	   "SKK の学習結果ファイルを作りました"
	 "I have created an SKK study file for you" )))
  (if (or (null skk-study-alist)
	  force
	  (skk-yes-or-no-p (format "%s を再読み込みしますか？" skk-study-file)
			   (format "Reread %s?" skk-study-file) ))
      (progn
	(or nomsg
	    (skk-message "%s の SKK 学習結果を展開しています..."
			 "Expanding SKK study of %s ..."
			 (file-name-nondirectory skk-study-file) ))
	;; 安定したらディフォルトを nil にするね。
	(if skk-study-check-alist-format
	    (skk-study-check-alist-format skk-study-file) )
	(setq skk-study-alist (skk-study-read-1 skk-study-file))
	(setq skk-study-last-read (current-time))
	(if (null skk-study-alist)
	    nil
	  (or nomsg
	      (progn
		(skk-message
		 "%s の SKK 学習結果を展開しています...完了！"
		 "Expanding SKK study of %s ...done"
		 (file-name-nondirectory skk-study-file) )
		(sit-for 1)
		(message "") ))))))

(defun skk-study-read-1 (file)
  ;; read FILE and return alist.
  (with-temp-buffer
    (let ((version-string
	   (format ";;; skk-study-file format version %s\n"
		   skk-study-file-format-version )))
      (insert-file-contents-as-coding-system
       (cond ((and skk-jisyo-code
		   (or (coding-system-p skk-jisyo-code)
		       (and (fboundp 'find-coding-system)
			    (find-coding-system skk-jisyo-code) )))
	      skk-jisyo-code )
	     ((and skk-jisyo-code (stringp skk-jisyo-code))
	      (cdr (assoc skk-jisyo-code skk-coding-system-alist)) )
	     (t (cdr (assoc "euc" skk-coding-system-alist))) )
       file )
      (if (= (buffer-size) 0)
	  ;; bare alist
	  (insert version-string "((okuri-ari) (okuri-nasi))") )
      (goto-char (point-min))
      (if (looking-at (regexp-quote version-string))
	  (read (current-buffer))
	(skk-error
	 "skk-study-file フォーマットのバージョンが一致しません"
	 "skk-study-file format version is inconsistent" )))))

;;;###autoload
(defun skk-study-check-alist-format (alist-file)
  "ALIST-FILE の連想リストのフォーマットをチェックする。"
  (interactive
   (list (read-file-name
	  (format "Alist file to check: (default: %s) " skk-study-file)
	  default-directory skk-study-file )))
  (skk-message "%s ファイルの連想リストのフォーマットチェックを行なっています..."
	       "Checking %s file alist format..." alist-file )
  (or (skk-study-check-alist-format-1 (skk-study-read-1 alist-file))
      (skk-error "%s の連想リストのフォーマットは壊れています"
		 "%s alist format is corrupt" alist-file ))
  (skk-message
   "%s ファイルの連想リストのフォーマットチェックを行なっています...完了!"
   "Checking %s file alist format... done" alist-file )
  (sit-for 1)
  (message "") )

(defun skk-study-check-alist-format-1 (alist)
  (if (not (and (= (length alist) 2) (assq 'okuri-ari alist)
		(assq 'okuri-nasi alist) ))
      nil
    (catch 'exit
      (let ((index '(okuri-ari okuri-nasi))
	    (func (function
		   (lambda (str)
		     (let ((len (length str)))
		       (and
			(> len 1)
			(skk-ascii-char-p (skk-str-ref str (1- len))) )))))
	    alist2 e f )
	(while index
	  (and (eq (car index) 'okuri-nasi)
	       (setq func
		     (function
		      (lambda (str)
			(let ((len (length str)))
			  (cond ((= len 1))
				((not (skk-ascii-char-p (skk-str-ref str (1- len)))))
				((skk-ascii-char-p (skk-str-ref str (- len 2)))) ))))))
	  (setq alist2 (cdr (assq (car index) alist)))
	  (while alist2
	    (setq e (car alist2))
	    (or (funcall func (car e))
		;; 見出し語のチェック
		(throw 'exit nil) )
	    (setq f (cdr e))
	    (while f
	      (if (not (and
			;; 直前の変換の情報
			(consp (car (car f)))
			;; 関連語リスト
			(listp (cdr (car f))) ))
		  (throw 'exit nil) )
	      (setq f (cdr f)) )
	    (setq alist2 (cdr alist2)) )
	  (setq index (cdr index)) )
	t ))))

(defun skk-study-prin1 (form &optional stream)
  (let ((print-readably t)
	print-level print-length print-quoted )
    (prin1 form stream) ))

(defun skk-study-chomp (nth list)
  ;; LIST := '(A B C D), NTH := 1
  ;; -> '(A B)
  (and (> nth -1) (setcdr (nthcdr nth list) nil))
  list )

(defadvice skk-kakutei-initialize (before skk-study-ad activate)
  (let ((kakutei-word (ad-get-arg 0))
	(count 0) data max vector )
    (when kakutei-word
      (setq data (cons skk-henkan-key kakutei-word))
      (setq vector (nthcdr 2 skk-study-data-ring))
      (setq max (length vector))
      (catch 'exit
	(while (> max count)
	  (and (equal (aref vector count) data)
	       (throw 'exit nil) )
	  (setq count (1+ count)) )
	(ring-insert skk-study-data-ring data) ))))
   
(defadvice skk-undo-kakutei (after skk-study-ad activate)
  (let ((last (ring-ref skk-study-data-ring 0))
	(last2 (ring-ref skk-study-data-ring 1))
	target )
    (if (and last last2)
	(progn
	  (setq target (assoc (car last)
			      (assq (cond ((skk-get-last-henkan-data 'okuri-char)
					   'okuri-ari )
					  (t 'okuri-nasi) )
				    skk-study-alist )))
	  (setq target (delq (assoc last2 (cdr target)) target)) ))))

;; time utilities...
;;  from ls-lisp.el.  Welcome!
(defun skk-study-time-lessp (time0 time1)
  (let ((hi0 (car time0))
	(hi1 (car time1))
	(lo0 (nth 1 time0))
	(lo1 (nth 1 time1)) )
    (or (< hi0 hi1) (and (= hi0 hi1) (< lo0 lo1))) ))

(add-hook 'skk-before-kill-emacs-hook 'skk-study-save)
(provide 'skk-study)
;;; Local Variables:
;;; End:
;;; skk-study.el ends here
