;;; -*- Emacs-Lisp -*-
;;; $Id: irex-tougou.el,v 3.7 1999/02/04 06:19:22 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-tougou)
(require 'irex-common)
(require 'irex-judge)


;;; 変数の宣言
(defvar irex-tougou-tree nil "構文木のデータを格納する変数")



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

(defsubst irex-tougou-read-tag (tag) "\
指定されたタグを検査する関数
空白文字と改行を読み飛ばした直後に <TAG〜> が見つかった場合は
先頭の < の位置を返し、かつ、> の直後に point を移動する。
そのタグが見つからなければ nil を返し、point は移動しない。
"
  (let ((org (point)))
    (skip-chars-forward " \t\n\f\r")
    (if (looking-at (concat "<" tag "[> \t\n\f\r]"))
	(prog1 (point)
	  (skip-chars-forward "^>")
	  (goto-char (1+ (point))))
      (goto-char org)
      nil)))


(defsubst irex-tougou-read-pairtag (tag &optional limit) "\
指定されたタグを検査する関数
irex-tougou-read-tag は
	<TAG〜>
という形式のタグを検査する場合に使うのに対して、この関数は
	<TAG〜> … </TAG>
という形式のタグを検査する場合に利用する。返り値及び副作用は
irex-tougou-read-tag と同じ。
LIMIT が指定されている場合は、</TAG> を検索する範囲を限定する。
"
  (let ((p (irex-tougou-read-tag tag)))
    (if p
	(prog1 p
	  (or (search-forward (concat "</" tag ">") limit t)
	      (error "Missing tag : </%s>" tag))
	  ))))


(defun irex-tougou-parse-system (symbol) "\
<SYSTEM> タグを解析する関数
見つかったタグに関する情報は symbol の属性配列の形で保存される。

system-rank  : 検索結果の irex-browse を実行中のシステムによる順位
system-score : 検索結果の irex-browse を実行中のシステムによるスコア
"
  (let ((top (irex-tougou-read-tag "SYSTEM")) str)
    (prog1 top
      (and top
	   (stringp irex-judge-current-sid)
	   (setq str (buffer-substring top (point)))
	   (or (string-match "[ \t\n\f\r]SID=\\([^> \t\n\f\r]+\\)[> \t\n\f\r]" str)
	       (error "%s" "Can't get SID from <SYSTEM> tag."))
	   (string= irex-judge-current-sid (irex-match-string 1 str))
	   (or (string-match "[ \t\n\f\r]RANK=\\([0-9]+\\)[> \t\n\f\r]" str)
	       (error "%s" "Can't get RANK from <SYSTEM> tag."))
	   (put symbol 'system-rank (irex-match-string 1 str))
	   (string-match "[ \t\n\f\r]\\(SIM\\|SCORE\\)=\\([^> \t\n\f\r]+\\)[> \t\n\f\r]" str)
	   (put symbol 'system-score (irex-match-string 2 str))))))


(defun irex-tougou-parse-judge_info (symbol) "\
<JUDGE> タグを解析する関数
見つかったタグに関する情報は symbol の属性配列の形で保存される。

judge-alist     : 判定者の PID をキーとしてスコアを値とする連想配列
judge-repeat    : irex-judge を実行中の判定者が判定を行なった回数 (REPEAT= の値)
judge-tag-start : irex-judge を実行中の判定者のタグの先頭を指す marker
judge-tag-end   : irex-judge を実行中の判定者のタグの末尾を指す marker

ただし、irex-judge を実行中の判定者がまだ判定を行なっていない場合は、

judge-tag-start : nil
judge-tag-end   : <JUDGE> タグの先頭

となる。<JUDGE> タグが見つからなかった場合は nil を返す。
"
  (or (get symbol 'judge-tag-end)
      (put symbol 'judge-tag-end (point-marker)))
  (let (x y pid)
    (if (setq x (irex-tougou-read-pairtag "JUDGE"))
	(progn
	  ;; <JUDGE> タグが発見された場合の処理
	  (setq y (point))
	  ;; 見つかったタグの PID とスコアを連想配列に記憶する
	  (put symbol 'judge-alist
	       (cons (cons (progn
			     (goto-char (+ x 6))
			     (or (re-search-forward "[ \t\n\f\r]PID=\\([0-9]+\\)[> \t\n\f\r]" y t)
				 (error "%s" "Can't get PID from <JUDGE> tag."))
			     (setq pid (irex-match-string 1)))
			   (progn
			     (goto-char (1- (point)))
			     (or (re-search-forward ">[ \t\n\f\r]*\\([ABC]\\??\\)[ \t\n\f\r]*</" y t)
				 (error "%s" "Can't get SCORE from <JUDGE> tag."))
			     (irex-match-string 1)))
		     (get symbol 'judge-alist)))
	  ;; 見つかったタグが判定作業中の判定者のものならば、そのタグの始点/終点などを記録する
	  (if (and (stringp irex-judge-current-pid)
		   (equal irex-judge-current-pid pid))
	      (progn
		(put symbol 'judge-tag-start (progn (goto-char x) (point-marker)))
		(if (re-search-forward "[ \t\n\f\r]REPEAT=\\([0-9]+\\)[> \t\n\f\r]" y t)
		    (put symbol 'judge-repeat (string-to-number (irex-match-string 1))))
		(put symbol 'judge-tag-end (progn (goto-char y) (point-marker)))))
	  (goto-char y)))))


(defun irex-tougou-parse-comment (symbol) "\
<COMMENT> タグを解析する関数
見つかったタグに関する情報は symbol の属性配列の形で保存される。

comment-str-start : irex-judge を実行中の判定者のつけたコメントの先頭を指す marker
comment-str-end   : irex-judge を実行中の判定者のつけたコメントの末尾を指す marker

タグの先頭と末尾ではなく、コメント本文の先頭と末尾を指していることに注意すること。
ただし、irex-judge を実行中の判定者がコメントをつけていない場合は、

comment-str-start : nil
comment-str-end   : <COMMENT> タグの最初

となる。<COMMENT> タグが見つからなかった場合は nil を返す。
"
  (or (get symbol 'comment-str-end)
      (put symbol 'comment-str-end (point-marker)))
  (let (x y)
    (if (setq x (irex-tougou-read-tag "COMMENT"))
	(prog1 t
	  (setq y (point))
	  (or (search-forward "</COMMENT>" nil t)
	      (error "Missing tag : %s" "</COMMENT>"))
	  (if (and (stringp irex-judge-current-pid)
		   (equal irex-judge-current-pid
			  (save-excursion
			    (goto-char (+ x 8))
			    (or (re-search-forward "[ \t\n\f\r]PID=\\([0-9]+\\)[> \t\n\f\r]" y t)
				(error "%s" "Can't get PID from <COMMENT> tag."))
			    (irex-match-string 1))))
	      (save-excursion
		(put symbol 'comment-str-end   (progn (goto-char (- (point) 10)) (point-marker)))
		(put symbol 'comment-str-start (progn (goto-char y) (point-marker)))
		))))))


(defun irex-tougou-parse-result_info () "\
<CAND> タグを解析する関数
次のような値を持つ1つの cons cell を返り値として返す。
    car = document number
    cdr = 解析結果を属性配列として保持しているシンボル
副作用として </CAND> の直後に point を移動する。
タグが見つからなかった場合は nil を返す。
"
  (if (irex-tougou-read-tag "CAND")
      ;; <CAND> タグが見つかった場合 -> 解析開始
      (let (x y (s (make-symbol "result_info")))
	;; <DOCNO> タグ
	(or (setq x (irex-tougou-read-pairtag "DOCNO"))
	    (error "%s" "Missing tag : <DOCNO>"))
	(setq y (point))
	(goto-char (+ x 6))
	(or (re-search-forward ">[ \t\n\f\r]*\\([0-9]+\\)[ \t\n\f\r]*</" y t)
	    (error "%s" "Can't get document number from <DOCNO> tag."))
	(put s 'docno (setq x (irex-match-string 1)))
	(goto-char y)
	(while (if (not (setq y (irex-tougou-read-tag "/CAND"))) ; </CAND> タグ
		   (or (irex-tougou-parse-system s)	; <SYSTEM> タグ
		       (irex-tougou-parse-judge_info s)	; <JUDGE> タグ
		       (irex-tougou-parse-comment s)	; <COMMENT> タグ
		       (error "Unknown tag: %s"
			      (buffer-substring (point) (min (point-max) (+ 10 (point))))))
		 (or (get s 'judge-tag-end)
		     (set-marker (put s 'judge-tag-end (make-marker)) y))
		 (or (get s 'comment-str-end)
		     (set-marker (put s 'comment-str-end (make-marker)) y))
		 nil))
	(cons x s))))


(defun irex-tougou-parse-buffer (buffer) "\
指定されたバッファを解析して構文木を生成する関数
構文解析に成功した場合は TOPIC-ID を返す。
構文解析に失敗した場合は nil を返す。
"
  (cond
   (irex-tougou-tree
    (irex-erase-marker irex-tougou-tree)
    (setq irex-tougou-tree nil)))
  (save-excursion
    (set-buffer buffer)
    (condition-case err
	(let (x list menu (case-fold-search t))
	  ;; <IR-MERGE-RESULT> を調べる
	  (save-excursion
	    (goto-char (point-min))
	    (while (irex-tougou-read-tag "IR-MERGE-RESULT")
	      (goto-char (+ 9 (prog1 (or (irex-tougou-read-pairtag "TOPIC-ID")
					 (error "%s" "Missing tag : <TOPIC-ID>"))
				(setq x (point)))))
	      (or (re-search-forward ">[ \t\n\f\r]*\\([0-9]+\\)[ \t\n\f\r]*</" x t)
		  (error "%s" "Can't get topic id from <TOPIC-ID> tag."))
	      (setq list (cons (list (irex-match-string 1)
				     (goto-char x)
				     (if (search-forward "</IR-MERGE-RESULT>" nil t)
					 (- (point) 18)
				       (error "%s" "Missing tag : </IR-MERGE-RESULT>")))
			       list))))
	  (setq x 0)
	  (setq menu (mapcar
		      '(lambda (e) (cons e (setq x (1+ x)))) ; x = <IR-MERGE-RESULT> タグの数
		      (sort (mapcar 'car list) 'string<)))
	  (setq list (if (= x 1) (car list)
		       ;; <IR-MERGE-RESULT> が複数含まれている場合 -> ユーザーに選択させる
		       (message "このバッファには複数のトピックに関する情報が含まれています。")
		       (ding)
		       (sleep-for 2)
		       (while (string= "" (setq x (completing-read
						   "判定するトピックの ID を入力して下さい: "
						   menu nil t))))
		       (assoc x list)))
	  ;; 選択された <IR-MERGE-RESULT> タグの内部を解析する
	  (save-restriction
	    (narrow-to-region (nth 1 list) (nth 2 list))
	    (goto-char (point-min))
	    (while (setq x (irex-tougou-parse-result_info))
	      (setq irex-tougou-tree (cons x irex-tougou-tree)))
	    (skip-chars-forward " \t\n\r\f")
	    (or (= (point) (point-max))
		(error "%s" "Not-parsed data remains")))
	  (setq irex-tougou-tree
		(if (stringp irex-judge-current-sid)
		    ;; irex-browse を実行中の場合は RANK の値によってソートする
		    (mapcar 'cdr
			    (sort (mapcar (function
					   (lambda (c)
					     (cons (if (get (cdr c) 'system-rank)
						       (string-to-number (get (cdr c) 'system-rank))
						     999999) ; これは無限大のつもり
						   c)))
					  (nreverse irex-tougou-tree))
				  (function (lambda (a b) (< (car a) (car b))))))
		  (nreverse irex-tougou-tree)))
	  (car list))
      (error (princ (format "%d 行付近で構文解析に失敗しました : %s" (count-lines 1 (point)) err)) nil))))





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

(defsubst irex-tougou-get-result_info (docno)
  (cdr (assoc docno irex-tougou-tree)))

(defsubst irex-tougou-get-system-rank (docno)
  (get (irex-tougou-get-result_info docno) 'system-rank))

(defsubst irex-tougou-get-system-score (docno)
  (get (irex-tougou-get-result_info docno) 'system-score))

(defsubst irex-tougou-get-judge_info-score (docno pid)
  (cdr (assoc pid (get (irex-tougou-get-result_info docno) 'judge-alist))))

(defsubst irex-tougou-get-judge_info-repeat (docno)
  "判定中の判定者が判定を繰り返した回数を返す関数"
  (or (get (irex-tougou-get-result_info docno) 'judge-repeat) 0))

(defun irex-tougou-get-comment-string (docno)
  "判定中の判定者が挿入したコメントを返す関数"
  (let ((info (irex-tougou-get-result_info docno)) top)
    (if (and info (setq top (get info 'comment-str-start)))
	(save-excursion
	  (set-buffer (marker-buffer top))
	  (buffer-substring top (get info 'comment-str-end)))
      "")))

(defun irex-tougou-get-all-docno-list ()
  "全ての記事番号のリストを返す関数"
  (mapcar 'car irex-tougou-tree))

(defun irex-tougou-get-all-judge-list ()
  "判定に参加している全ての判定者の PID のリストを返す関数"
  (let (l)
    (mapcar
     '(lambda (e)
	(mapcar
	 '(lambda (j)
	    (or (member (car j) l)
		(setq l (cons (car j) l))))
	 (get (cdr e) 'judge-alist)))
     irex-tougou-tree)
    (sort l 'string<)))






;;;----------------------------------------------------------------------
;;;	バッファを変更する関数
;;;----------------------------------------------------------------------

(defun irex-tougou-write-judge_info (docno score &optional time) "\
判定中の判定者の判定結果をバッファに書き込む関数
TIME に整数が指定されている場合は、判定に要した時間を積算し、判定した
回数に1を加える。判定した回数を返す。
それ以外の場合は、判定に要した時間と回数を0にリセットして、0を返す。
指定された DOCNO のエントリが存在しなければなにもせずに nil を返す。
"
  (let ((case-fold-search t)		; 大文字 / 小文字を無視して検索
	(info (irex-tougou-get-result_info docno)))
    (if info
	;; 指定された docno のエントリが存在している -> 書き込み開始
	(save-excursion
	  (let ((alist (get info 'judge-alist))
		(top   (get info 'judge-tag-start))
		(end   (get info 'judge-tag-end)))
	    (set-buffer (marker-buffer end))
	    (let ((buffer-read-only nil))
	      (if top
		  ;; 対象となる <JUDGE> タグが既に存在している場合 -> 必要な部分を置換する
		  (progn
		    ;; REPEAT= を検索 / 書き換え
		    (goto-char (+ top 6))
		    (if (re-search-forward "\\([ \t\n\f\r]REPEAT=\\)\\([0-9]+\\)\\([> \t\n\f\r]\\)" end t)
			(replace-match (format "\\1%d\\3"
					       (put info 'judge-repeat
						    (if (integerp time)
							(1+ (string-to-number (irex-match-string 2)))
						      0))))
		      ;; REPEAT= が見つからなかった場合 -> 挿入
		      (re-search-forward "\\([ \t\n\f\r]PID=[0-9]+\\)\\([> \t\n\f\r]\\)" end)
		      (replace-match (format "\\1 REPEAT=%d\\2"
					     (put info 'judge-repeat (if (integerp time) 1 0)))))
		    ;; TIME= を検索 / 書き換え
		    (goto-char (+ top 6))
		    (if (re-search-forward "\\([ \t\n\f\r]TIME=\\)\\([0-9]+\\)\\([> \t\n\f\r]\\)" end t)
			(replace-match (format "\\1%d\\3"
					       (if (integerp time)
						   (+ time (string-to-number (irex-match-string 2)))
						 0)))
		      ;; TIME= が見つからなかった場合 -> 挿入
		      (re-search-forward "\\([ \t\n\f\r]PID=[0-9]+\\)\\([> \t\n\f\r]\\)" end)
		      (replace-match (format "\\1 TIME=%d\\3"
					     (if (integerp time) time 0))))
		    ;; SCORE を検索 / 書き換え
		    (goto-char (1- (point)))
		    (re-search-forward ">[ \t\n\f\r]*[ABC]\\??</" end)
		    (replace-match (concat ">" score "</") t t)
		    (setcdr (assoc irex-judge-current-pid alist) score))
		;; 対象となる <JUDGE> タグがまだ存在しない場合 -> 新規に挿入する
		(or (char-equal ?\n (char-after (1- (goto-char end))))
		    (insert-before-markers "\n"))
		(setq top (point))
		(insert-before-markers (format "<JUDGE PID=%s TIME=%d REPEAT=%d>%s</JUDGE>"
					       irex-judge-current-pid
					       (if (integerp time) time 0)
					       (put info 'judge-repeat (if (integerp time) 1 0))
					       score))
		(or (char-equal ?\n (char-after (point)))
		    (progn
		      (insert-before-markers "\n")
		      (set-marker (get info 'judge-tag-end) (1- (point)))))
		(put info 'judge-alist (cons (cons irex-judge-current-pid score) alist))
		(put info 'judge-tag-start (progn (goto-char top) (point-marker))))
	      ))
	  (get info 'judge-repeat)))))	; 正常に書き換えられた場合 -> 書き換えた回数を返す


(defun irex-tougou-write-comment (docno begin end) "\
判定中の判定者のコメントをバッファに書き込む関数
START と END は marker でなければならない。
指定された DOCNO のエントリが存在しなければなにもしない。
"
  (let ((info (irex-tougou-get-result_info docno)))
    (if info
	(save-excursion
	  (set-buffer (marker-buffer (get info 'comment-str-end)))
	  (let ((buffer-read-only nil))
	    (if (get info 'comment-str-start)
		;; 対象となる <COMMENT> が既に存在している場合 -> コメント部分を削除
		(delete-region (goto-char (get info 'comment-str-start))
			       (get info 'comment-str-end))
	      ;; 対象となる <COMMENT> がまだない場合 -> タグを挿入
	      (or (char-equal ?\n (char-after (1- (goto-char (get info 'comment-str-end)))))
		  (insert "\n"))
	      (insert (format "<COMMENT PID=%s></COMMENT>" irex-judge-current-pid))
	      (if (char-equal ?\n (char-after (point)))
		  (goto-char (- (point) 10))
		(insert "\n")
		(goto-char (- (point) 11)))
	      (put info 'comment-str-start (point-marker)))
	    ;; コメントを挿入
	    (insert-buffer-substring (marker-buffer begin) begin end)
	    (set-marker (get info 'comment-str-end) (point))
	    t)))))


(defun irex-tougou-exit ()
  (cond
   (irex-tougou-tree
    (irex-erase-marker irex-tougou-tree)
    (setq irex-tougou-tree nil))))