;;; trr-sessions - (C) 1996 Yamamoto Hirotaka (ymmt@is.s.u-tokyo.ac.jp)
;;; modified by KITAJIMA Akira <kitajima@ics.es.osaka-u.ac.jp>
;;; Last modified on Sun Apr 14 15:26:49 1996 (original version)

(eval-when-compile
  ;; Shut Emacs' byte-compiler up
  (setq byte-compile-warnings '(redefine callargs)))

;; for now, there is only one type of session is supported.
(defun TRR:get-event ()
  (prog1
      (let ((ev (read-event)))
	(while (listp ev)
	  (message (if TRR:japanese "ずるは駄目だよう" "Don't play foul!"))
	  (ding)
	  (setq ev (read-event)))
	(if (integerp ev)
	    (if (/= ev 12)
		ev
	      (redraw-display)
	      (TRR:get-event))
	  (cond ((eq ev 'return) ?\r)
		((eq ev 'tab) ?\t)
		((eq ev 'backspace) ?\b)
		((eq ev 'newline) ?\n)
		((eq ev 'escape) ?\e)
		(t ?\a))))
    (message " ")))

;;; TRR:fll および TRR:lnk は rattt-4.0 から移植しました。
;;; 以下から入手できます。
;;; http://www.cs.washington.edu/homes/yasushi/rattt4.0.tar.gz
(defun TRR:fll (str1 str2)
  (let* ((len1 (length str1))
	 (len2 (length str2))
	 i j m
	 (maxn 0) maxi maxj
	 (match (make-vector (1+ len2) nil)))
    (setq j len2)
    (while (>= j 0)
      (aset match j (make-vector (1+ len1) 0))
      (setq j (1- j)))
    (setq j 0)
    (while (< j len2)
      (setq i 0)
      (while (< i len1)
	(aset (aref match (1+ j)) (1+ i)
	      (setq m (if (= (aref str1 i) (aref str2 j))
			  (1+ (aref (aref match j) i))
			(max (aref (aref match (1+ j)) i)
			     (aref (aref match j) (1+ i))))))
	(and (> m maxn)
	     (setq maxn m
		   maxi i
		   maxj j))
	(setq i (1+ i)))
      (setq j (1+ j)))
    (list maxi maxj maxn match)))

(defun TRR:lnk (fll-list)
  " STR2 の方の合ってた index のリストを返す"
  (let* ((i     (car fll-list))
	 (j     (car (cdr fll-list)))
	 (n     (car (cdr (cdr fll-list))))
	 (match (car (cdr (cdr (cdr fll-list)))))
	 link)
    (while (> n 0)
      (setq n (1- n))
      (while (and (> i 0)
		  (= (aref (aref match (1+ j)) (1+ i))
		     (aref (aref match (1+ j)) i)))
	(setq i (1- i)))
      (while (and (> j 0)
		  (= (aref (aref match (1+ j)) (1+ i))
		     (aref (aref match j) (1+ i))))
	(setq j (1- j)))
      (setq link (cons j link)
	    i (1- i)
	    j (1- j)))
    link))

(defun TRR:eelll-match (template string)
  "TEMPLATEをお手本として入力された文字列STRINGの採点をする。"
  (let ((quest template)
	(link (list  '(0 . 0)))
	(len (length string))
	(max (length template))
	(j 0) i)
    (while (< j len)
      (setq i 0)
      (while (< i max)
	(and (= (aref string j) (aref template i))
	     (let ((l link) (p nil) (i+1 (1+ i)) (j+1 (1+ j)) dif)
	       (while l
		 (if (and (>= i (car (car l)))
			  (>= j (cdr (car l))))
		     (setq l nil)
		   (setq p (car l) l (cdr l))))
	       (if p
		   (if (or (> (setq dif (- (+ (car p) (cdr p)) i+1 j+1)) 0)
			   (and (= dif 0) (> i+1 (car p))))
		       (progn (setcar p i+1)
			      (setcdr p j+1)))
		 (setq link (cons (cons i+1 j+1) link)))))
	(setq i (1+ i)))
      (setq j (1+ j)))
    (let ((res nil)
	  (l link))
      (while l
	(if (> (car (car l)) 0)
	    (setq res (cons (1- (cdr (car l))) res)))
	(setq l (cdr l)))
      res)))

(defun TRR:put-answer (str2 link)
  (and window-system
       TRR:correct-color-name
       TRR:miss-color-name
       (let (pos)
	 (put-text-property 0 (length str2) 'face TRR:miss-face-name str2)
	 (while link
	   (setq pos (car link)
		 link (cdr link))
	   (put-text-property pos (1+ pos) 'face TRR:correct-face-name str2))))
  (insert str2))


(defun TRR:one-session ()
  (other-window -1)
  (TRR:write-graph TRR:list-of-eval 0
		   (if TRR:japanese
		       "今回の得点グラフ"
		     "Score Graph for this time"))
  (other-window -1)
  (TRR:print-log)
  (other-window 2)
  (if (or TRR:typist-flag TRR:small-window-flag)
      (set-window-configuration TRR:win-conf-typist))
  (erase-buffer)
  (save-excursion
    (set-buffer (TRR:display-buffer))
    (if (not TRR:start-flag)
	(setq TRR:start-flag t))
    (copy-to-buffer (TRR:trainer-menu-buffer)
		    (point)
		    (progn
		      (forward-line (* 3 TRR:text-lines))
		      (point))))
  (goto-char (point-min))
  (forward-line 1)
  (setq TRR:correct-char-count 0
	TRR:whole-char-count 0)
  (or (eobp)
      (let* ((lines (/ (count-lines (point-min) (point-max)) 3))
	     (text-pos (save-excursion (forward-line -1) (point)))
	     (truncate-lines t)
	     inputted-string
	     (current-text-string
	      (buffer-substring text-pos
				(save-excursion
				  (goto-char text-pos)
				  (end-of-line)
				  (1- (point))))))
	(message (if TRR:japanese "ようい!" "Ready!"))
	(setq TRR:ch (TRR:get-event)
	      TRR:start-time (current-time-string))
	(message (if TRR:japanese "スタート!" "start!"))
	(while (and (> lines 0)
		    (/= TRR:ch 18)   ;; if TRR:ch = ^R then restart
		    (/= TRR:ch 3))   ;; if TRR:ch = ^C then quit
	  ;; TRR:ch   今読み出した文字
	  ;; text-pos 現在のテキストの位置
	  (if (/= TRR:ch 13)
	      ;; 通常の文字
	      (setq inputted-string (concat inputted-string
					    (char-to-string TRR:ch))
		    TRR:ch (TRR:get-event))
	    ;; 一行終了
	    (setq TRR:end-time (current-time-string))
	    (let* ((link
		    (TRR:lnk (TRR:fll current-text-string inputted-string)))
;		    (TRR:eelll-match current-text-string inputted-string)
		   (match-count (length link))
		   (inputted-length (length inputted-string))
		   (current-line-length (length current-text-string))
		   ;; 得点の計算
		   (one-line-correct (let ((diff (- inputted-length
						    current-line-length)))
				       (cond ((< diff 0)
					      ;; テキストより少ない
					      match-count)
					     ((< match-count diff)
					      ;; 間違いが多すぎる
					      0)
					     (t
					      (- match-count diff))))))
	      (TRR:put-answer inputted-string link)
	      (setq TRR:whole-char-count
		    (+ TRR:whole-char-count current-line-length 1)
		    TRR:correct-char-count
		    (+ TRR:correct-char-count one-line-correct 1)))
					; +1 は CR の分
	    (setq lines (1- lines))
	    (or (= lines 0)
		(progn
		  ;; 次の行の順備
		  (forward-line 3)
		  (setq text-pos (save-excursion (forward-line -1) (point))
			inputted-string nil
			current-text-string (buffer-substring
					     text-pos
					     (save-excursion
					       (goto-char text-pos)
					       (end-of-line)
					       (1- (point))))
			TRR:ch (TRR:get-event))))))
	;; dummy
	(recenter -2)))
  (forward-line 1)
  (and (/= TRR:ch 18)   ;; if TRR:ch = ^R then restart
       (/= TRR:ch 3)    ;; if TRR:ch = ^C then quit
       (progn
	 (message (if TRR:japanese "スペースキーを押して下さい"
		    "Press Space key."))
	 (let ((ev (read-event)))
	   (while (or (not (integerp ev))
		      (/= ev ? ))
	     (message (if TRR:japanese "スペースキーを押して下さい"
			"Press Space key."))
	     (setq ev (read-event))))))
  (if (or TRR:typist-flag TRR:small-window-flag)
      (set-window-configuration TRR:win-conf)))

;;; trr-sess.el ends here.