;;; eelll.el --- EELLL (ELisp implemented CATTT)

;; Copyright (C) 1991--2002  Kaoru Maeda, Yasushi Saito and Akira Kitajima

;; Author: Kaoru Maeda <maeda@src.ricoh.co.jp>
;;	Yasushi Saito <yasushi@is.s.u-tokyo.ac.jp>
;;	Akira Kitajima <kitajima@isc.osakac.ac.jp>
;; Maintainer: Akira Kitajima

;; $Id: eelll.el,v 1.11 2002/03/19 00:32:15 kitajima Exp $

;; 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 of the License, 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., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA.

;;; Code:

(require 'tc-sysdep)
(require 'tc)
(require 'tc-bushu)
(require 'tc-help)
(autoload 'Helper-describe-mode "helper" nil t)

(if (not (fboundp 'tcode-use-package))
    (tcode-init)
  (if (assoc default-input-method tcode-package-name-alist)
      (tcode-use-package default-input-method)
    (tcode-use-package (car (car tcode-package-name-alist))))
  (tcode-inactivate))

;;  Version
(defun eelll-version ()
  "EELLL のバージョンを表示する。"
  (interactive)
  (if (interactive-p)
      (message "EELLL version %s" (eelll-version))
    (substring "$Revision: 1.11 $" 11 -2)))

;;;
;;;  Variable
;;;

(defgroup eelll nil
  "EELLL (A T-Code trainer)."
  :group 'tcode)

(defcustom eelll-expert nil
  "Tコードの上級者かどうか。"
  :type 'boolean :group 'eelll)

(defcustom eelll-display-help-threshold 10
  "ヘルプの表示/非表示を切り替えるエラー率のしきい値(%)。"
  :type 'integer :group 'eelll)

(defvar eelll-text (concat tcode-data-directory "EELLLTXT")
  "*EELLLの練習テキストファイル")

(defvar eelll-move-cursor nil
  "*non-nilにするとキー入力のたびにカーソルを進める。")

(defvar eelll-configuration-file-name (concat tcode-data-directory
					      "eelll-conf.el")
  "*EELLLの設定ファイル名。
このファイルは自動的に書き換えられるので、
ユーザーは内容を変更してはいけない。")

(defvar eelll-last-lesson nil
  "最後に練習したレッスン番号")

(load eelll-configuration-file-name t)

(defconst eelll-buffer-name "*EELLL*"
  "EELLLで練習するバッファ名")

(defconst eelll-text-buffer " *eelll: text*"
  "EELLLの練習テキストを入れておくバッファ名")

(defvar eelll-help-remove-interval 25
  "*EELLLの説明を消すまでの時間(秒)")

(defconst eelll-help-buffer-name " *EELLL-Help*"
  "EELLLで打ち方を表示するバッファ名")

(defvar eelll-help-window-margin
  (if (and (>= emacs-major-version 21)
	   window-system)
      3
    1)
  "*EEELLの打ち方を表示するときのウィンドウの高さのマージン")

(defvar eelll-use-image (or (and (featurep 'bitmap)
				 (or (tcode-mule-2-p)
				     (tcode-mule-3-p)
				     (tcode-mule-4-p))
				 (eq window-system 'x))
			    (and (tcode-mule-4-p)
				 (> emacs-major-version 20)
				 (display-images-p)))
  "* ビットマップを使ったヘルプを表示するかどうか。
ビットマップを表示できるウィンドウシステム上でのみ使用可能。")

(when (fboundp 'defface)
    (defface eelll
      '((t (:font "-*-fixed-medium-r-normal-*-16-*-*-*-*-*-*-*")))
      "*ビットマップを使った EELLL でのへルプのフェイス"
      :group 'eelll))

(defvar eelll-previous-error-rate 0)

(defvar eelll-stroke-to-string-function
  (if (>= emacs-major-version 21)
      'tc-image-stroke-to-string
    'tc-bitmap-stroke-to-string))

(defvar eelll-original-window-configuration nil)
(defvar eelll-window-configuration nil)

(defvar eelll-total-time 0)
(defvar eelll-total-stroke 0)
(defvar eelll-total-error 0)
(defvar eelll-lesson-no nil)
(defvar eelll-first-hand nil)
(defvar eelll-second-hand nil)
(defvar eelll-upper-row nil)
(defvar eelll-lesson-chars nil)
(defvar eelll-text-line nil)
(defvar eelll-start-time nil)
(defvar eelll-strokes 0)
(defvar eelll-error-strokes 0)
(defvar eelll-lesson-string nil)
(defvar eelll-lesson-pattern-string nil)
(defvar eelll-key-table nil)

(defvar eelll-exit-hook (if (featurep 'frame)
			    'eelll-remove-frame))
;;; for `eelll-other-frame'
(defvar eelll-frame-parameters 
  '((name . "EELLL")
    (font . "-*-fixed-medium-r-normal-*-16-*-*-*-*-*-*-*"))
  "*`eelll-other-frame'で用いるフレームのパラメータ。")
(defvar eelll-frame nil)

;;;
;;;  Text
;;;

(defun eelll-prepare-text (num)
  "練習テキストNUMを用意する。NUMがnilならば次のレッスンを用意する。"
  (save-excursion
    (tcode-set-work-buffer eelll-text-buffer eelll-text)
    (widen)
    (goto-char (point-min))
    (or (if num
	    (re-search-forward
	     (concat "\f\nLesson \\(" (int-to-string num) "\\):") nil t)
	  (and (or (null eelll-last-lesson)
		   (re-search-forward (concat "\f\nLesson \\("
					      (int-to-string eelll-last-lesson)
					      "\\):")
				      nil t))
	       (re-search-forward "\f\nLesson \\([0-9]+\\):" nil t)))
	(error "練習テキスト%sはありません。" (if num (int-to-string num) "")))
    (setq eelll-lesson-string (buffer-substring (match-beginning 1)
						(match-end 1))
	  eelll-lesson-no (string-to-int eelll-lesson-string))
    (setq eelll-first-hand (looking-at "[Rr]"))
    (setq eelll-second-hand (looking-at ".[Rr]"))
    (setq eelll-upper-row (looking-at "..!"))
    (forward-line 1)
    (if (looking-at "^Lesson-chars: ")
	(let ((eol (save-excursion (end-of-line 1) (point))))
	  (skip-chars-forward "^ " eol)
	  (setq eelll-lesson-chars (buffer-substring (1+ (point)) eol))
	  (forward-line 1)))
    (let ((p (point)))
      (forward-page 1)
      (narrow-to-region p (1- (point)))
      (goto-char p)))
  (setq eelll-last-lesson eelll-lesson-no))


(defun eelll-lesson-line ()
  "練習テキストの次の行をとってくる。終わりならnilを返す。
eelll-text-line:	印字イメージ"
  (save-excursion
    (set-buffer eelll-text-buffer)
    (skip-chars-forward " \t\n\f" (point-max))
    (and (not (eobp))
	 (let ((p (point)))
	   (forward-line 1)
	   (setq eelll-text-line (buffer-substring p (1- (point))))
	   eelll-text-line))))

(defun eelll-stroke-for-char (ch)
  "CH(全角一文字)の打ち方を返す。Tコードで入力できなければnilを返す。"
  (let ((stroke (or (tcode-stroke-for-char ch)
		    (tcode-stroke-for-char (tcode-2-to-1 ch)))))
    (if (and stroke
	     (= (length stroke) 2))
	stroke
      nil)))

(defun eelll-inputs-for-char (ch)
  "CH (全角1文字)の打ち方(文字列のリスト)を返す。
Tコードで入力できなければnilを返す。"
  (let ((stroke-list (or (tcode-stroke-for-char ch)
			 (tcode-stroke-for-char (tcode-2-to-1 ch)))))
    (cond (stroke-list
	   (mapcar (lambda (key)
		     (aref eelll-key-table key))
		   stroke-list))
	  (tcode-another-table
	   (let ((i (1- (length tcode-another-table))))
	     (catch 'found
	       (while (>= i 0)
		 (let ((c (aref tcode-another-table i)))
		   (if (string= ch (if (and c (symbolp c))
				       (eval c)
				     c))
		       (throw 'found (list (aref eelll-key-table i) ? ))))
		 (setq i (1- i))))))
	  ((string= ch " ")
	   (list ? )))))

;;;
;;;  Stroke chart
;;;
(defun eelll-draw-chart ()
  "練習テキストの練習対象となる文字のストローク表を作る。"
  (save-excursion
    (set-buffer (get-buffer-create eelll-help-buffer-name))
    (widen)
    (erase-buffer)
    (goto-char (point-min))
    (let ((i 0)
	  j k
	  (c (if eelll-second-hand 1 4)))
      (while (< i 4)
	(setq i (1+ i) j 0)
	(while (< j 4)
	  (insert "    ")
	  (setq j (1+ j) k 0)
	  (while (< k 5)
	    (setq k (1+ k))
	    (insert "‐‐‐‐‐  ")
	    (if (= k c) (insert "  ")))
	  (delete-horizontal-space)
	  (insert "\n"))
	(if (< i 4) (insert "\n"))))
    (mapcar
     (lambda (c)
       (let ((stroke (eelll-stroke-for-char (char-to-string c))))
	 (when (and stroke
		    (= (length stroke) 2))
	   (let* ((second (car (cdr stroke)))
		  (fc (% (car stroke) 5))
		  (fr (/ (car stroke) 10))
		  (sc (% second 5))
		  (sr (/ second 10)))
	     (goto-line (+ (* sr 5) fr 1))
	     (move-to-column (+ 4 (* 12 sc) (* 2 fc)
				(if (> sc (if eelll-second-hand 0 3)) 2 0)))
	     (tcode-delete-char 1)
	     (insert (char-to-string c))))))
     (tcode-string-to-char-list eelll-lesson-chars))
    (goto-char (point-min))
    (forward-line 1)
    (delete-region (point-min) (point))
    (unless eelll-upper-row
      (forward-line 5)
      (delete-region (point-min) (point))
      (forward-line 4)
      (delete-region (point)
		     (save-excursion (forward-line 1)
				     (point)))
      (forward-line 4)
      (delete-region (point)
		     (save-excursion (forward-line 1)
				     (point))))
    (setq eelll-lesson-pattern-string (concat (if eelll-first-hand "R" "L")
					      "->"
					      (if eelll-second-hand "R" "L")))
    (set-buffer-modified-p nil)))

;;;
;;;  String Matching
;;;
(defun eelll-subsequence (seq n)
  ;; return first N elements of SEQ
  (let ((seq (copy-sequence seq)))
    (if (> (length seq) n)
	(setcdr (nthcdr (1- n) seq) nil))
    (if (<= n 0)
	nil
      seq)))

(defun eelll-match (string quest)
  "QUESTをお手本として入力された文字列STRINGの採点をする。
2要素のリスト(RESULT ERROR)を返す。"
  (let* ( ;; template は ((文字 . ストローク数) . ストローク) のリスト
	 (template (delq nil
			 (mapcar
			  (lambda (c)
			    (let ((stroke (eelll-inputs-for-char
					   (char-to-string c))))
			      (and stroke
				   (cons (cons c (length stroke))
					 stroke))))
			  (tcode-string-to-char-list quest))))
	 ;; template-length は template の長さ
	 (template-length (length template))
	;; vtemplate は (文字 . ストローク数) のベクター
	 (vtemplate (vconcat (mapcar 'car template)))
	 ;; key-list は入力された文字のリスト
	 (key-list (tcode-string-to-char-list string))
	 (key-length (length string))
	 (link (list '(0 . 0)))
	 (last (1- (length string)))
	 (j 0))
    (while template
      (let ((correct (mapconcat 'char-to-string (cdr (car template)) nil))
	    (correct-length (cdr (car (car template))))
	    (inputted key-list))
	(while inputted
	  (when (string= correct
			 (mapconcat 'char-to-string
				    (eelll-subsequence inputted correct-length)
				    nil))
	    (let* ((l link)
		   (next-input (nthcdr correct-length inputted))
		   (next-i (- key-length (length next-input)))
		   (next-template (cdr template))
		   (next-j (- template-length (length next-template)))
		   pair)
	      (catch 'finish
		(while l
		  (if (and (>= (- key-length (length inputted))
			       (car (car l)))
			   (>= (- template-length (length template))
			       (cdr (car l))))
		      (throw 'finish nil)
		    (setq pair (car l)
			  l (cdr l)))))
	      (if pair
		  (let ((dif (+ (- (car pair) next-i) (- (cdr pair) next-j))))
		    (when (or (> dif 0)
			      (and (= dif 0)
				   (> next-i (car pair))))
		      (setcar pair next-i)
		      (setcdr pair next-j)))
		(setq link (cons (cons next-i next-j) link)))))
	  (setq inputted (cdr inputted))))
      (setq template (cdr template)))
    (let* ((res (vconcat (tcode-string-to-char-list string)))
	   (pi (length string))
	   (pj template-length)
	   (err 0)
	   (l link)
	   (i (car (car l))))
      (while (> i 0)
	(let* ((j (cdr (car l)))
	       (correct (aref vtemplate (1- j))))
	  (aset res (- i 1) (car correct))
 	  (let ((n (1- (cdr correct))))
 	    (while (>= n 1)
 	      (aset res (- i 1 n) nil)
 	      (setq n (1- n))))
	  (setq err (+ err (max (- pi i) (- pj j)) (- (cdr correct))))
	  (setq pi i
		pj j
		l (cdr l)
		i (car (car l)))))
      (list (mapconcat (lambda (c) (if c (char-to-string c)))
		       res nil)
	    (+ err (max pi pj))))))

;;;
;;;  Mode setup
;;;

(defvar eelll-mode-map nil
  "EELLL モードで使うキーマップ")
(if eelll-mode-map
    ()
  (setq eelll-mode-map (make-keymap))
  (substitute-key-definition nil 'eelll-undefined eelll-mode-map)
  (define-key eelll-mode-map "\177" 'eelll-delete-char)
  (define-key eelll-mode-map "\e" 'ESC-prefix)
  (define-key eelll-mode-map "\C-c" 'mode-specific-command-prefix)
  (define-key eelll-mode-map "\C-j" 'eelll-return)
  (define-key eelll-mode-map "\C-m" 'eelll-return)
  (define-key eelll-mode-map "\C-g" 'eelll-confirm-quit)
  (define-key eelll-mode-map "\C-l" 'eelll-redisplay)
  (define-key eelll-mode-map "\C-u" 'universal-argument)
  (define-key eelll-mode-map "\C-x" 'Control-X-prefix)
  (define-key eelll-mode-map "\C-]" 'abort-recursive-edit)
  (define-key eelll-mode-map "?" 'eelll-help)
  (define-key eelll-mode-map " " 'eelll-key)

  (let ((i (1- (length tcode-keymap-table))))
    (while (>= i 0)
      (if (<= 0 (aref tcode-keymap-table i))
	  (define-key eelll-mode-map (char-to-string (+ i ? )) 'eelll-key))
      (setq i (1- i)))))

(defun eelll-mode ()
  "EELLL は Emacs Lisp で実現されたTコード練習プログラムです。
画面に表示された文字列をそのまま入力してください。
1行の入力が終わったらリターンキーを打ってください。

画面の上半分には今のレッスンで習う文字のストローク表が表示されています。

EELLL 内ではほとんどのコマンドが禁止されています。
まず \\[switch-to-buffer] で他のバッファに移ってから\
コマンドを実行してください。
なお、\\[eelll-confirm-quit] で EELLL を中断します。"
  (use-local-map eelll-mode-map)
  (setq major-mode 'eelll-mode)
  (setq mode-name "EELLL")
  (setq mode-line-format '("-----EELLL"
			   (eelll-lesson-string
			    (": lesson " eelll-lesson-string))
			   "%-"))
  (run-hooks 'eelll-mode-hook))

(defun eelll-help ()
  "EELLL の説明を表示する。"
  (interactive)
  (Helper-describe-mode)
  (kill-buffer "*Help*")
  (eelll-redisplay))

(defun eelll-undefined ()
  (interactive)
  (message (substitute-command-keys
	    "\\[switch-to-buffer] SOME-BUFFER first.")))

(defun eelll-delete-char ()
  (interactive)
  (message "間違いを気にせずどんどん入力してください。"))

;;;
;;; 専用の入力補完付きのcompleting-read
;;;
;;; "?"で一覧が見れます。

(defun eelll-completing-read ()
  "入力補完付きで、練習テキスト番号をミニバッファから入力する。
Emacs内部のcompletionの実装上の問題のため、「?」を
入力した時にしか一覧は見えない。"
  (let (lesson-alist key val orig-minibuffer-completion-help)
    (save-excursion
      (tcode-set-work-buffer eelll-text-buffer eelll-text)
      (widen)
      (goto-char (point-min))
      (while (re-search-forward "^Lesson \\([0-9]+\\):[rRlL]+" nil t)
	(setq key (buffer-substring (match-beginning 1) (match-end 1)))
	(forward-line 2)
	(setq val (buffer-substring (point)
				    (save-excursion (end-of-line) (point))))
	(setq lesson-alist (cons (cons key val) lesson-alist))))
    (setq orig-minibuffer-completion-help
	  (symbol-function 'minibuffer-completion-help))
    (unwind-protect
	(progn
	  (fset 'minibuffer-completion-help
		(symbol-function 'eelll-minibuffer-completion-help))
	  (let* ((hist (mapcar 'car lesson-alist))
		 (pos (if eelll-last-lesson
			  (- (length hist)
			     (length (member (format "%d" eelll-last-lesson)
					     hist))
			     -1)))
		 (str (cond ((tcode-nemacs-p)
			     (completing-read 
			      "練習テキスト[`?'で一覧] "
			      lesson-alist nil t
			      (if eelll-last-lesson
				  (format "%d" eelll-last-lesson)
				"")))
			    ((tcode-xemacs-p)
			     (completing-read
			      "練習テキスト[`?'で一覧] "
			      lesson-alist nil t
			      (if eelll-last-lesson
				  (format "%d" eelll-last-lesson)
				"")
			      (if pos (cons 'hist (list pos)) (list 'hist))))
			    (t
			     (completing-read 
			      "練習テキスト[`?'で一覧] "
			      lesson-alist nil t
			      (if eelll-last-lesson
				  (format "%d" eelll-last-lesson)
				"")
			      (if pos (cons 'hist pos) 'hist))))))
	    (if (string= str "")
		nil
	      (list (string-to-int str)))))
      (fset 'minibuffer-completion-help orig-minibuffer-completion-help))))

(defun eelll-minibuffer-completion-help ()
  "EELLL用の補完候補を表示する。
`minibuffer-completion-help'を置き換える。"
  (interactive)
  (with-output-to-temp-buffer "*Completions*"
    (eelll-display-completion-list
     (all-completions (save-excursion
			(buffer-substring (progn (beginning-of-line) (point))
					  (progn (end-of-line) (point))))
			minibuffer-completion-table))))

(defun eelll-display-completion-list (x)
  "練習テキスト一覧を表示する。
`display-completion-list'を置き換える。"
  (princ "    ---- 練習テキスト一覧 ----\n")
  (setq x (sort x (lambda (x y)
		    (< (string-to-int x) (string-to-int y)))))
  (while x
    (princ (car x))
    (princ ":")
    (princ (cdr (assoc (car x) lesson-alist)))
    (princ "\n")
    (setq x (cdr x))))

;;;; ビットマップ表示

(defun eelll-put-help-char (c)
  (let* ((ch (char-to-string c))
	 (stroke (or (tcode-stroke-for-char ch)
		     (tcode-stroke-for-char (tcode-2-to-1 ch))
		     (let ((another (member ch
					    (mapcar 'eval 
						    (tcode-string-to-char-list
						     tcode-another-table)))))
		       (if another
			   (list (- (length tcode-another-table)
				    (length another)))))))
	 (s (if stroke
		(funcall eelll-stroke-to-string-function stroke)))
	 (ex-col (/ (1- (length stroke)) 2)))
    (if (<= (* (+ help-count ex-col) 7)
	    (* (frame-width) 0.60))
	(setq help-count (1+ help-count))
      (insert "\n")
      (end-of-line)
      (insert "\n")
      (setq help-count 1))
    (insert "|")
    (insert (or s "-- --"))
    (save-excursion
      (forward-line)
      (end-of-line)
      (insert "|")
      (insert "  " (format "%2s" ch) " ")
      (let ((l ex-col))
	(while (> l 0)
	  (insert "      ")
	  (setq l (1- l))
	  (setq help-count (1+ help-count)))))))

(defun eelll-insert-bitmap-help (string)
  (let ((chars (tcode-string-to-char-list string))
	(help-count 0)
	(tcode-stroke-to-string-separator "-")
	(tcode-stroke-to-string-opener "")
	(tcode-stroke-to-string-closer "")
	(beg (progn 
	       (insert "\n")
	       (point))))
    (mapcar 'eelll-put-help-char chars)
    (insert "\n")
    (forward-line)
    (when (fboundp 'put-text-property)
      (put-text-property beg (point) 'face 'eelll))))

;;;
;;;  Main
;;;

(defun eelll (&optional lesson)
  "EELLL を始める。詳しくは `eelll-mode' の解説を見よ。"
  (interactive (eelll-completing-read))
  (unless eelll-key-table
    (let ((n (1- (length tcode-keymap-table))))
      (setq eelll-key-table (make-vector 40 nil))
      (while (>= n 0)
	(let ((key (aref tcode-keymap-table n)))
	  (if (>= key 0)
	      (aset eelll-key-table key (+ n ? )))
	  (setq n (1- n))))))
  (setq eelll-original-window-configuration (current-window-configuration))
  (setq eelll-previous-error-rate (if eelll-expert 0 100))
  (eelll-prepare-text lesson)
  (eelll-setup-lesson)
  (message (substitute-command-keys "\\[eelll-help] でヘルプ")))

(defun eelll-setup-lesson ()
  (eelll-draw-chart)
  (switch-to-buffer eelll-buffer-name)
  (buffer-disable-undo)
  (eelll-mode)
  (widen) 
  (erase-buffer)
  (delete-other-windows)
  (if eelll-use-image
      (if (>= emacs-major-version 21)
	  (require 'tc-image)
	(require 'tc-bitmap))
    (when (>= eelll-previous-error-rate eelll-display-help-threshold)
      (split-window-vertically
       (save-excursion
	 (set-buffer eelll-help-buffer-name)
	 (setq mode-line-format
	       '("-----EELLL Help"
		 (eelll-lesson-string
		  (": lesson " eelll-lesson-string))
		 (eelll-lesson-pattern-string
		  ("  (" eelll-lesson-pattern-string ")"))
		 "%-"))
	 (+ (count-lines (point-min) (point-max)) 
	    eelll-help-window-margin)))
      (switch-to-buffer eelll-help-buffer-name)
      (goto-char (point-min))
      (other-window 1)))
  (setq eelll-window-configuration (current-window-configuration))
  (setq eelll-start-time nil
	eelll-error-strokes 0
	eelll-strokes 0)
  (save-excursion
    (set-buffer eelll-text-buffer)
    (goto-char (point-min)))
  (insert "リターンキーを打てば始まります。 "))

(defun eelll-key ()
  (interactive)
  (save-excursion
    (set-buffer " *eelll: strokes*")
    (insert (char-to-string last-command-char)))
  (if eelll-move-cursor
      (insert " ")))

(defun eelll-return ()
  (interactive)
  (if eelll-start-time
      (progn
	(delete-region (point) (progn (beginning-of-line 1) (point)))
	(let* ((str (save-excursion
		      (set-buffer " *eelll: strokes*")
		      (buffer-string)))
	       (res (eelll-match str eelll-text-line))
	       (err (car (cdr res))))
	  (insert (car res))
	  (if eelll-use-image
	      (let ((wrong-chars (tcode-uniq 
				  (tcode-subtract-set
				   (tcode-string-to-char-list eelll-text-line)
				   (tcode-string-to-char-list (car res))))))
		(when wrong-chars
		  (insert "\n\n==[間違えた字]==")
		  (eelll-insert-bitmap-help
		     (mapconcat 'char-to-string wrong-chars nil))
		  (insert "\n================"))))
	  (setq eelll-strokes (+ eelll-strokes (length str))
		eelll-error-strokes (+ eelll-error-strokes err))))
    (setq eelll-start-time (eelll-current-time)))
  (if (null (eelll-lesson-line))
      (eelll-end-lesson)
    (save-excursion
      (set-buffer (get-buffer-create " *eelll: strokes*"))
      (widen) (erase-buffer))
    (when eelll-use-image
      (insert "\n")
      (if (>= eelll-previous-error-rate eelll-display-help-threshold)
	  (eelll-insert-bitmap-help eelll-text-line)))
    (insert "\n\n" eelll-text-line "\n")
    (eelll-redisplay)))

(defun eelll-redisplay ()
  "EELLL の画面を表示し直す。"
  (interactive)
  (set-window-configuration eelll-window-configuration)
  (goto-char (point-max))
  (recenter -1))

(defun eelll-current-time ()
  (let ((str (current-time-string)))
    (string-match "\\([0-9][0-9]\\):\\([0-9][0-9]\\):\\([0-9][0-9]\\)" str)
    (+ (* 3600 (string-to-int (substring str
					 (match-beginning 1)
					 (match-end 1))))
       (* 60 (string-to-int (substring str (match-beginning 2) (match-end 2))))
       (string-to-int (substring str (match-beginning 3) (match-end 3))))))

(defun eelll-percentage (num den)
  (let ((res%  (min 9999 (/ num (max 1 den)))))
    (format "%d.%d" (/ res% 10) (% res% 10))))

(defun eelll-stroke-per-min (stroke sec)
  "1分あたりのストローク数を表した文字列を返す。"
  (let ((stroke-per-min (/ (* (float stroke) 60) sec)))
    (format (if (< stroke-per-min 10) "%.1f" "%.f") stroke-per-min)))

(defun eelll-time-per-stroke (time stroke)
  "1ストロークあたりの時間を表した文字列を返す。"
      (if (>= time stroke)
	  (format "%.1f" (/ (float time) stroke))
	(format "%.f ミリ" (/ (* (float time) 1000) stroke))))

(unless (fboundp 'float)
  ;; float の扱えない Emacs (NEmacs) の場合
  ;; オーバーフローしないように桁をずらす。

  (defun eelll-stroke-per-min (stroke sec)
    "1分あたりのストローク数を表した文字列を返す。"
    (while (>= stroke 10000)
      (setq sec (/ sec 2)
	    stroke (/ stroke 2)))
    (setq stroke (* stroke 600))
    (let ((10stroke-per-min (/ stroke sec)))
      (if (< 10stroke-per-min 100)
	  (format "%d.%1d" (/ 10stroke-per-min 10) (% 10stroke-per-min 10))
	(format "%d" (/ 10stroke-per-min 10)))))

  (defun eelll-time-per-stroke (time stroke)
    "1ストロークあたりの時間を表した文字列を返す。"
    (if (>= time stroke)
	(let ((10time-per-stroke (/ (* time 10) stroke)))
	  (format "%d.%d " (/ 10time-per-stroke 10) (% 10time-per-stroke 10)))
      (while (>= time 8000)
	(setq time (/ time 2)
	      stroke (/ stroke 2)))
      (let ((1000time-per-stroke (/ (* time 1000) stroke)))
	(format "%d ミリ" 1000time-per-stroke)))))

(defun eelll-display-score (time stroke err)
  (if (> stroke 0)
      (let ((cnt (- stroke err)))
	(set-buffer eelll-buffer-name)
	(insert "\n\n(総打鍵成績)毎打鍵 "
		(eelll-time-per-stroke time stroke) "秒  "
		"毎分 " (eelll-stroke-per-min stroke time) " 打鍵\n")
	(if (> cnt 0)
	    (insert "(実打鍵成績)毎打鍵 "
		    (eelll-time-per-stroke time cnt) "秒  "
		    "毎分 " (eelll-stroke-per-min cnt time) " 打鍵\n"))
	(setq eelll-previous-error-rate (if (> stroke 0)
					    (/ (* 100 err) stroke)
					  100))
	(insert "              エラーレート "
		(eelll-percentage (* 1000 err) stroke)
		"%\n"))))

(defun eelll-end-lesson ()
  (let ((time (% (- (eelll-current-time) eelll-start-time -86399) 86400)))
    (setq eelll-total-time (+ eelll-total-time time)
	  eelll-total-stroke (+ eelll-total-stroke eelll-strokes)
	  eelll-total-error (+ eelll-total-error eelll-error-strokes))
    (eelll-display-score time eelll-strokes eelll-error-strokes)
    (delete-other-windows)
    (recenter -1)
    (if (y-or-n-p "もう一度トライしますか? ")
	(eelll-setup-lesson)
      (if (y-or-n-p "次のレッスンに進みますか? ")
	  (progn (eelll-prepare-text nil)
		 (setq eelll-previous-error-rate (if eelll-expert 0 100))
		 (eelll-setup-lesson))
	(eelll-end))))
  (message ""))

(defun eelll-save-configuration ()
  "`eelll-last-lesson' の値を設定ファイルに保存する。
設定ファイル名は `eelll-configuration-file-name' で指定する。"
  (and eelll-configuration-file-name
       (file-writable-p eelll-configuration-file-name)
       (save-excursion
	 (kill-buffer
	  (prog1
	      (set-buffer (get-buffer-create " *eelll: temp*"))
	    (insert (format "(setq eelll-last-lesson %d)\n" eelll-last-lesson))
	    (let ((backup-inhibited t))
	      (write-file eelll-configuration-file-name)))))))

(defun eelll-confirm-quit ()
  "EELLL を終了するかどうか確認し、終了する。"
  (interactive)
  (and (y-or-n-p "EELLL を終了しますか? ")
       (eelll-end t)))

(defun eelll-end (&optional abort)
  (if abort
      ()
    (set-buffer eelll-buffer-name)
    (widen)
    (erase-buffer)
    (insert "総合成績\n\n")
    (eelll-display-score eelll-total-time eelll-total-stroke eelll-total-error)
    (insert "\n    入力打鍵数 " (int-to-string eelll-total-stroke) " 打鍵. ")
    (insert "所要時間 " (int-to-string eelll-total-time) " 秒.\n")
    (recenter -1)
    (eelll-save-configuration)
    (message "おつかれさまでした。どれかキーをおしてください。")
    (condition-case ()
	(read-char)
      (error)))
  (kill-buffer eelll-help-buffer-name)
  (set-window-configuration eelll-original-window-configuration)
  (run-hooks 'eelll-exit-hook)
  (message ""))

(defun eelll-remove-frame ()
  "EELLL用のフレームがあれば削除する。"
  (interactive)
  (if (and eelll-frame
	   (frame-live-p eelll-frame))
      (make-frame-invisible eelll-frame)))

(defun eelll-other-frame ()
  "フレームを作成してEELLLを始める。"
  (interactive)
  (if (or (null eelll-frame)
	  (not (frame-live-p eelll-frame)))
      (setq eelll-frame (make-frame eelll-frame-parameters)))
  (unless (frame-visible-p eelll-frame)
    (make-frame-visible eelll-frame))
  (select-frame eelll-frame)
  (raise-frame eelll-frame)
  (call-interactively 'eelll))

;;;
;;; 練習テキストデータの整形
;;;

(defun tcode-key-address-right-p (address)
  (let ((location (tcode-get-key-location address)))
    (>= (cdr location) 6)))

(defun tcode-key-address-left-p (address)
  (let ((location (tcode-get-key-location address)))
    (< (cdr location) 6)))

(defun eelll-compile-text (recompile-all)
  "練習テキストのLesson-chars: 行を作る。
RECOMPILE-ALL が non-nil の場合には、
既存のLesson-chars:をすべて削除してから新たに作り直す。"
  (interactive "P")
  (find-file eelll-text)
  (let ((reached-eob nil) (eelll-buffer (current-buffer)))
    (save-restriction
      (widen)
      (goto-char (point-min))
      (save-excursion
	(set-buffer (get-buffer-create " *eelll: lessons*"))
	(delete-region (point-min) (point-max)))
      (while (and (not reached-eob) (not (eobp)))
	(let ((point (point)))
	  (narrow-to-page 1)
	  (if (= point (point)) (setq reached-eob t)))
	(goto-char (point-min))
	(skip-chars-forward "^0-9")
	(message (buffer-substring (point)
				   (save-excursion (end-of-line 1) (point))))
	(skip-chars-forward "^:" (save-excursion (end-of-line 1) (point)))
	(setq eelll-first-hand (looking-at ":[Rr]"))
	(setq eelll-second-hand (looking-at ":.[Rr]"))
	(forward-line 1)
	(if (and recompile-all (looking-at "^Lesson-chars: "))
	    (delete-region (point) (save-excursion (forward-line) (point))))
	(if (not (looking-at "^Lesson-chars: "))
	    (let ((where (point))
		  (chars nil)
		  (upper nil)
		  c last)
	      (while (not (eobp))
		(skip-chars-forward " \t\n\f" (point-max))
		(while (not (eolp))
		  (setq chars (cons (buffer-substring (point)
						      (progn (forward-char 1)
							     (point)))
				    chars))))
	      (setq chars (sort chars 'string<))
	      (goto-char where)
	      (if chars (insert "Lesson-chars: "))
	      (while chars
		(catch 'next
		  (setq c (car chars) chars (cdr chars))
		  (if (string= c last) (throw 'next nil))
		  (setq last c)
		  (setq c (eelll-stroke-for-char c))
		  (if (and c
			   (eq eelll-first-hand
			       (tcode-key-address-right-p (car c)))
			   (eq eelll-second-hand
			       (tcode-key-address-right-p (car (cdr c)))))
		      (progn
			(if (or (< (car c) 10) (< (car (cdr c)) 10))
			    (setq upper t))
			(insert last)))))
	      (insert "\n")
	      (if upper
		  (progn
		    (goto-char (point-min))
		    (end-of-line 1)
		    (or (= (preceding-char) ?!)
			(insert "!"))))
	      (sit-for 0)
	      (if (input-pending-p) (ding)))))
      (message "Compilation end.")
      (let ((buffer (get-buffer eelll-text-buffer)))
	(and buffer
	     (kill-buffer buffer))))))

(provide 'eelll)

;;; eelll.el ends here