;;; -*- Emacs-Lisp -*-
;;; $Id: irex-mainichi.el,v 3.3 1999/06/04 07:08:06 tsuchiya Exp $

;; This file is part of IREX tools.

;; Please refer "Copyright file" at the root directory.
;; (C) IREX committee IREX実行委員会. All rights reserved.  


;;; 依存関係の宣言
(provide 'irex-mainichi)
(require 'irex-judge)
(require 'irex-common)


;;; 定数 / 変数の宣言
(defvar irex-mainichi-directory (expand-file-name "MAINICHI" irex-root-directory)
  "*毎日新聞全文記事データの置かれているディレクトリ")

(defvar irex-mainichi-retrieval-program
  (or (let (f)
	(cond
	 ((file-executable-p (setq f (expand-file-name "IR_TOOLS/perl/irex-article.perl" irex-root-directory))) f)
	 ((file-executable-p (setq f (expand-file-name "perl/irex-article.perl" irex-root-directory))) f)))
      "irex-article.perl")
  "判定する記事のみを全文データから取り出すプログラム")

(defvar irex-mainichi-retrieval-options
  (let* ((l)
	 (f (lambda (f) (if (file-readable-p f)
			   (setq l (cons f (cons "-f" l)))
			 ))))
    (funcall f (expand-file-name "mai94.sgml" irex-mainichi-directory))
    (funcall f (expand-file-name "mai95.sgml" irex-mainichi-directory))
    (or l (funcall f (expand-file-name "sample.sgml" irex-mainichi-directory)))
    (reverse l))
  "irex-article-retrieval-program に与えるオプションのリスト")

(defvar irex-mainichi-max-option-length nil "\
*シェルの引数として与えることの出来る文字列の最大長
整数値が指定されている場合は、コマンドライン引数を指定された値の長さに
分割して irex-mainichi-retrieval-program を複数回に分けて呼び出す。そ
れ以外の場合は、一度に全ての記事を取得することを試みる。")

(defvar irex-mainichi-coding-system (and (featurep 'mule)
					 (if (>= emacs-major-version 20) 'euc-japan-unix *euc-japan*unix))
  "*毎日新聞全文記事データが格納されているファイルの漢字コード")

(defvar irex-mainichi-tree nil "構文木を格納する変数")




;;;----------------------------------------------------------------------
;;;	構文木を生成する関数
;;;----------------------------------------------------------------------

(defun irex-mainichi-parse-doc () "\
<DOC>タグを解析する関数
<DOC> タグの内部を解析した結果を属性リストの形で保持している symbol を返す。

docno          : Document Number
headline-start : 表題の先頭を指している marker
headline-end   : 表題の末尾を指している marker
text-start     : 本文の先頭を指している marker
text-end       : 本文の末尾を指している marker
"
  (let ((s (make-symbol "doc")))
    (and (skip-chars-forward " \t\n\f\r")
	 (looking-at "<DOC>")
	 (goto-char (match-end 0))
	 (re-search-forward "<DOCNO>\\s-*\\([0-9]+\\)\\s-*</DOCNO>" nil t)
	 (put s 'docno (irex-match-string 1))
	 (search-forward "<HEADLINE>" nil t)
	 (put s 'headline-start (point-marker))
	 (search-forward "</HEADLINE>" nil t)
	 (put s 'headline-end (save-excursion
				(goto-char (- (point) 11))
				(point-marker)))
	 (search-forward "<TEXT>" nil t)
	 (put s 'text-start (point-marker))
	 (search-forward "</TEXT>" nil t)
	 (put s 'text-end (save-excursion
			    (goto-char (- (point) 7))
			    (point-marker)))
	 (skip-chars-forward " \t\n\f\r")
	 (looking-at "</DOC>")
	 (goto-char (match-end 0))
	 s)
    ))


(defun irex-mainichi-exit ()
  (setq irex-mainichi-tree nil))





;;;----------------------------------------------------------------------
;;;	構文木からデータを取り出す関数
;;;----------------------------------------------------------------------

(defun irex-mainichi-get-date (docno)
  "指定された記事の日付を yy/mm/dd の形式で返す関数"
  (format "%s/%s/%s"
	  (substring docno 0 2)
	  (substring docno 2 4)
	  (substring docno 4 6)))

(defun irex-mainichi-get-headline (docno)
  "指定された記事の表題を返す関数"
  (let ((s (cdr (assoc docno irex-mainichi-tree))))
    (if s
	(save-excursion
	  (set-buffer (marker-buffer (get s 'headline-start)))
	  (save-restriction
	    (widen)
	    (buffer-substring (get s 'headline-start) (get s 'headline-end))
	    )))))

(defun irex-mainichi-get-text-region (docno) "\
指定された記事の本文の文頭と文末を返す関数
\(start . end\) という構造の cons cell を返す。
"
  (let ((s (cdr (assoc docno irex-mainichi-tree))))
    (if s (cons (get s 'text-start) (get s 'text-end)))
    ))





;;;----------------------------------------------------------------------
;;;	必要な記事データのみを取り出す関数
;;;----------------------------------------------------------------------

(defun irex-mainichi-retrieval-articles (docno-list) "\
指定された記事を全文データから取り出して current buffer に書き込む関数
"
  (widen)
  (erase-buffer)
  (if irex-mainichi-tree (irex-erase-marker irex-mainichi-tree))
  (let ((case-fold-search t)
	(p) (s)
	(file (buffer-file-name irex-judge-buffer)))
    (setq file (and (stringp file)
		    (format "%s.mai" (if (string-match "\.irj$" file) (substring file 0 -4) file))))
    ;; キャッシュを読み込む
    (if (and file (file-readable-p file))
	(progn
	  (message "キャッシュファイル %s を読み込んでいます..." file)
	  (let ((coding-system-for-read irex-mainichi-coding-system)
		(file-coding-system-for-read irex-mainichi-coding-system))
	    (insert-file-contents file))
	  (skip-chars-forward " \t\n\f\r")
	  (delete-region (point-min) (point))
	  (message "キャッシュを解析しています...")
	  (while (setq p (point)
		       s (irex-mainichi-parse-doc))
	    (if (member (get s 'docno) docno-list)
		(setq irex-mainichi-tree (cons (cons (get s 'docno) s) irex-mainichi-tree)
		      docno-list (delete (get s 'docno) docno-list))
	      ;; キャッシュに含まれている不要な記事を削除する
	      (message "Warning: 不要な記事がキャッシュに含まれています: docno=%s" (get s 'docno))
	      (skip-chars-forward " \t\n\f\r")
	      (delete-region p (point))
	      (insert "\n")		; </DOC>タグと<DOC>タグの間に改行が少なくとも1つあることを
	      (goto-char (1- (point)))	; 保証するためのコード
	      (mapcar (lambda (m) (if (markerp m) (set-marker m nil))) (symbol-plist s))
	      ))
	  (delete-region p (point-max)) ; 解析されずに残ったごみを削除
	  (insert "\n")
	  ))
    (if docno-list
	;; キャッシュにない記事がある場合 -> 全文記事データを検索
	(progn
	  (setq p (point)
		docno-list (sort docno-list 'string<))
	  (let ((coding-system-for-read irex-mainichi-coding-system)
		(coding-system-for-write irex-mainichi-coding-system)
		(default-process-coding-system
		  (cons irex-mainichi-coding-system irex-mainichi-coding-system)))
	    (if (catch 'retrive-error
		  (if (integerp irex-mainichi-max-option-length)
		      (let (argv len (list docno-list))
			(while list
			  (setq argv (reverse irex-mainichi-retrieval-options)
				len  (length irex-mainichi-retrieval-program))
			  (mapcar (lambda (s) (setq len (+ len 1 (length s)))) argv)
			  (while (and list
				      (< (setq len (+ len 1 (length (car list)))) irex-mainichi-max-option-length))
			    (setq argv (cons (car list) argv)
				  list (cdr list)))
			  (message "毎日新聞全文記事データから必要なデータを取り出しています... %d%%"
				   (floor (* (/ (- (length docno-list) (length list))
						(float (length docno-list)))
					     100)))
			  (if (/= 0 (apply 'call-process irex-mainichi-retrieval-program nil t nil (nreverse argv)))
			      (throw 'retrive-error t))))
		    (message "毎日新聞全文記事データから必要なデータを取り出しています...")
		    (/= 0 (apply 'call-process irex-mainichi-retrieval-program nil t nil
				 (append irex-mainichi-retrieval-options docno-list)))))
		(let ((str (buffer-substring p (point-max)))
		      (buf (generate-new-buffer "*IREX-ERROR*"))
		      (win (split-window)))
		  (set-buffer buf)
		  (set-window-buffer win buf)
		  (insert "Program: " irex-mainichi-retrieval-program "\n"
			  "Options: " (prin1-to-string irex-mainichi-retrieval-options) "\n"
			  "Docno list: " (prin1-to-string docno-list) "\n"
			  "---\n"
			  str)
		  (error "Some error is occured when executing \"%s\"" irex-mainichi-retrieval-program))))
	  (goto-char p)
	  (message "読み込んだ毎日新聞記事データを解析しています...")
	  (while (setq p (point)
		       s (irex-mainichi-parse-doc))
	    (setq irex-mainichi-tree (cons (cons (get s 'docno) s) irex-mainichi-tree)
		  docno-list (delete (get s 'docno) docno-list)))
	  (mapcar (lambda (docno) (message "Error: 足りない記事があります: docno=%s" docno)) docno-list)
	  (delete-region p (point-max)) ; 解析されずに残ったごみを削除
	  ;; キャッシュを更新する
	  (if (and file
		   (if (file-exists-p file)
		       (y-or-n-p (format "キャッシュファイル %s を上書きしてもいいですか? " file))
		     (y-or-n-p (format "キャッシュファイル %s が存在していません。新規生成しますか? " file))))
	      (if (file-writable-p file)
		  (if (get-file-buffer file)
		      (message "キャッシュファイル %s が既に開かれているので書き込めません。" file)
		    (message "キャッシュファイル %s に書き込んでいます..." file)
		    (if (>= emacs-major-version 20)
			(setq buffer-file-coding-system irex-mainichi-coding-system)
		      (setq file-coding-system irex-mainichi-coding-system))
		    (write-region (point-min) (point-max) file)
		    (message ""))
		(message "キャッシュファイル %s に書き込めません。" file)
		))))
    t))