scheme_baton.scm

#!/usr/bin/env gosh
;; 第1回 Scheme コードバトン
;;
;; ■ これは何か？
;;   Scheme のコードをバトンのように回していき面白い物ができあがるのを楽しむ遊びです。
;;   次回 Shibuya.lisp で成果を発表します。
;;   Scheme 初心者のコードを書くきっかけに、中級者には他人のコードを読む機会になればと思います。
;;
;; ■ 2 つのルール
;;
;;   (1)自分がこれだと思える変更をコードに加えて2日以内に次の人にまわしてください。
;;      「人に優しい」変更なら何でも良い。1文字の変更でも可。
;;      「人に優しい」とは例えば、次の人が読みやすいコードを書くなど。
;;       コードを削るのもあり。
;;
;;   (2)次の人にまわしコードが変更されるのを"見守る"。
;;       この説明書きを含めてバトンが伝わった事を必ず確認してください。
;;       止まっていたら助けてあげてください。
;;
;; ■ バトンの回し方
;;
;;    (1) 回ってきたバトンは http://gist.github.com/xxxx という URL のはずです。
;;    (2) fork をクリックしてください（アカウントを持っていない人はこのとき作成します）
;;    (3) edit で変更したファイルを貼り付けます。
;;    (4) 自分が fork した新しい URL を回してください
;;
;;
;; ■ 良くある質問
;;
;;   (a) 初心者です。参加したいけどちょっと不安です。
;;      higepon がフォローしますので大丈夫です。分からない事があれば遠慮無く聞いてください。
;;
;;   (b) 次にまわす人がいません
;;      higepon に知らせてください。twitter, 日記のコメントなどで。
;;
;;   (c) 次の人がコードを止めてしまいました
;;      残念ですが別の人にバトンを渡してください。
;;
;;   (d) Mosh で動かないとダメですか？
;;      いいえ。Scheme なら何でも良いです。Gauche, Ypsilon 用に書き換えるのも面白いですね。
;;      そのときは起動方法の説明も変えてください。
;;
;; ■ バトンの行方を記録
;;   名前(URL)：一言
;;   1. higepon (http://d.hatena.ne.jp/higepon/): 最初はコマンドライン英単語暗記ツールでした。これが何に化けるのか楽しみ。全く別物になるかな？
;;   2. yadokarielectric (http://d.hatena.ne.jp/yad-EL/20100110/p1)
;;   3. garaemon (http://garaemon.net/wordpress/?p=200)
;;   4. yshigeru (http://d.hatena.ne.jp/yshigeru/20100111/1263208636)
;;   5. g000001 (http://cadr.g.hatena.ne.jp/g000001/)
;;   6. masa.edw (http://d.hatena.ne.jp/masa_edw/20100113/1263396668)
;;   7. leque (http://d.hatena.ne.jp/leque/20100114/p1)
;;   8. emasaka (http://emasaka.blog65.fc2.com/blog-entry-700.html)
;;   9. kazu634 (http://d.hatena.ne.jp/sirocco634/20100117#1263736737)
;;  10. naoya_t (http://blog.livedoor.jp/naoya_t/): 改めてGaucheとmoshの共存を目指しました。
;;  11. snmsts (http://twitter.com/snmsts/) windowsのmoshでpdcursesをimportしてエラーをおこさずに動いてはいる…単語表示さない…48時間過ぎたorz
;;  12. Gemma (http://d.hatena.ne.jp/Gemma/20100124/1264344621) CGIにしました
;;  13. とおる。(http://twitter.com/torus/status/8260524063) 辞書ファイルをパラメタ化しました。
;;  14. (び) (http://twitter.com/bizenn/status/8409198193)
;;  15. nobsun (http://twitter.com/nobsun/status/8493438985)
;;  16. koguro (http://d.hatena.ne.jp/koguro/) 単体で動作するWebアプリにしました 
;;
;; =================================================================================================================================================
;;                            これより下がコードとその説明 - 変更・削除歓迎
;; =================================================================================================================================================
;;
;; ■動作方法
;;   Gauche (0.9) で動作します。(http://practical-scheme.net/gauche/index-j.html)
;;   デフォルトの辞書ファイルはwords.txtというファイル名で、カレントディレクトリに置いてください。
;;   ちなみに、Gauche のエンコーディングは utf-8 を使うようになっていないと動かないと思います。
;;
;;   scheme-baton.scm -p 8080 のようにポート番号を指定して起動すると、英単語練習モードになります。
;;   英単語練習モードでは、Webブラウザを使って英単語の知識の確認を行うことができます。
;;   http://localhost:<オプションで指定したポート番号>/quiz.html にアクセスするとテストが始まります。
;;   知っている単語なら "y" を、知らない単語なら "n" を入力していってください。(マウスでクリックするのもOK)
;;
;;   Webブラウザは、Safari 4, Firefoxで動作確認しています。
;;   GoogleChromeだとwavファイルの再生ができないみたいで音が出ません。(音が出ないだけで単語のテストはできます)
;;   IEでは、そもそもちゃんと動かないようです。
;;
;;   -p オプションを指定せず起動すると、英単語登録モードになります。コンソール上から英単語を登録することができます。
;;   
;;   -h オプションを指定すると、オプションの一覧が表示されます。
;;
;; ■辞書ファイルの指定
;;   起動時のオプション -f, --dict-file で辞書ファイルを指定できます。
;;   scheme-baton.scm -f mywords.txt    mywords.txtというファイルを辞書ファイルとして使う
;;
;; ■辞書ファイルの例
;;   http://gist.github.com/285224
;;
;; ■モジュールの構成
;;   このプログラムは、以下の4つのモジュールで構成されています。
;;   webserver:    とっても簡単なWebサーバ
;;   synthesizer:  とっても簡単なシンセサイザ。再生機能はありませんが、wavデータの生成ができます。
;;   quiz:         英単語辞書操作用API
;;   user:         本体のプログラム。コードの大部分がHTMLの記述のために使われています。
;;

;;;;
;;;; webserver module
;;;; とっても簡単なWebサーバ
;;;;

(define-module webserver
  (use file.util)
  (use gauche.net)
  (use gauche.selector)
  (use gauche.uvector)
  (use rfc.uri)
  (use srfi-1)
  (use srfi-13)
  (use text.html-lite)
  (use text.tree)
  (use util.list)

  (export query-parameter register-action! http-response start-webserver!)
  )

(select-module webserver)

;; リクエストからクエリパラメータのalistを生成します。
;;  req-alist: リクエストパラメータのalist
;;  戻り値: クエリパラメータのalist
(define (query-parameter req-alist)
  (map (lambda (str)
         (apply cons (string-split str "=")))
       (string-split (values-ref (uri-parse (assoc-ref req-alist 'path)) 5) "&")))

(define (read-request in)
  (define (read-request-line in)
    (let ((line (read-line in)))
      (if (eof-object? line)
          '()
          (rxmatch-let (#/([^ ]+) ([^ ]+) HTTP\/(\d+\.\d)/ line)
              (_ method path http-version)
            (read-message-headers in `((method . ,method)
                                       (path . ,path)
                                       (version . ,http-version)))))))
  (define (read-message-headers in req-alist)
    (let loop ((alist req-alist)
               (line (read-line in)))
      (if (or (eof-object? line) (= (string-length line) 0))
          (read-body in alist)
          (rxmatch-let (#/([^:\s]+):\s*(.*)/ line)
              (_ name value)
            (loop (alist-cons (string->symbol (string-downcase name))
                              value
                              alist)
                  (read-line in))))))
  (define (read-body in req-alist)
    (and-let* ((pair (assoc 'content-length req-alist)))
      (read-block (x->integer (cdr pair)) in))
    req-alist)
  (read-request-line in))

(define (write-response out req-alist status reason resp-alist data)
  (format out "HTTP/~a ~a ~a\r\n" (assoc-ref req-alist 'version) status reason)
  (let ((byte-data (coerce-to <u8vector> data)))
    (for-each (lambda (p)
                (format out "~a: ~a\r\n" (car p) (cdr p)))
              (append '(("Connection" . "close"))
                      (if (assoc :Content-Length resp-alist)
                          '()
                          (list (cons "Content-Length" (size-of byte-data))))
                      resp-alist))
    (display "\r\n" out)
    (write-block byte-data out)))

(define *action-table* (make-hash-table 'equal?))

;; HTTPレスポンスを生成します。
;;  body: レスポンスのボディ
;;  キーワード引数として、:status ステータスコード、:reason 理由文字列、その他何でも指定可能です。指定したものは全部レスポンスヘッダにつめられます。
;;  例えば、:Content-Type "text/html" とか指定すると、レスポンスヘッダに "Content-Type: text/html" と入ります。
;;  戻り値: HTTPレスポンス
(define (http-response body . opts)
  (let-keywords* opts ((status 200)
                       (reason (if (equal? status 200) "OK" ""))
                       . rest)
    (list status reason
          (let loop ((rest rest)
                     (alist '()))
            (if (null? rest)
                alist
                (loop (cddr rest) (alist-cons (car rest) (cadr rest) alist))))
          body)))

(define (error-not-found req-alist)
  (http-response (tree->string (html:html :lang "en"
                                          (html:head
                                           (html:meta :http-equiv "Content-Type"
                                                      :content "text/html; charset=utf-8")
                                           (html:title "Not Found"))
                                          (html:body "404 Not Found")))
                 :status 404 :reason "Not Found" :Content-Type "text/html"))

;; メソッドとパスに対応する処理を登録します。
;;  method: HTTPメソッド。"GET"みたいに文字列で指定します。
;;  path: パス
;;  proc: 処理。処理の中でHTTPレスポンスを返してください。
(define (register-action! method path proc)
  (hash-table-put! *action-table* (list (string-upcase method) path) proc))

(define (action method path)
  (hash-table-get *action-table* (list (string-upcase method) path) error-not-found))

;; Webサーバを起動します。
;;  port: ポート番号
;;  無限ループするので、止めたいときはCtrl-Cとかで止めてください。
(define (start-webserver! port)
  (let ((selector (make <selector>))
        (sock (make-server-socket 'inet port :reuse-addr? #t)))
    (selector-add! selector (socket-fd sock)
                   (lambda _
                     (let* ((client (socket-accept sock))
                            (http-in (socket-input-port client :buffering :full))
                            (http-out (socket-output-port client)))
                       (let ((req-alist (read-request http-in)))
                         (apply write-response http-out req-alist
                                ((action (assoc-ref req-alist 'method)
                                         (values-ref (uri-parse (assoc-ref req-alist 'path)) 4))
                                 req-alist)))
                       (socket-close client)))
                   '(r))
    (unwind-protect
     (while #t
       (selector-select selector #f))
     (socket-close sock))))

;;;; end of webserver module.

;;;;
;;;; synthesizer module
;;;; とっても簡単なシンセサイザ
;;;;

(define-module synthesizer
  (use gauche.uvector)
  (use util.list)
  (use gauche.collection)
  (use binary.pack)
  (use util.match)
  (use srfi-1)

  (export mml->riff)
  )
(select-module synthesizer)

;; RIFFフォーマットのwavデータを生成します。
;;  sampling-rate: サンプリングレート
;;  wave-data: 波形データ。振幅の値(-1から1の値)のリストになります。
;;  戻り値: wavデータの不完全文字列
;; ※手抜きしているので、リトルエンディアンの環境でしか動作しません。
(define (wave->riff sampling-rate wave-data)
  (let ((pcm-data (make-s16vector (length wave-data))))
    (do ((i 0 (+ i 1))
         (rest wave-data (cdr rest)))
        ((null? rest)
         (pack "A4VA4A4V!vvV!V!vvA4V!a*"
               (list "RIFF" (+ 36 (* (length wave-data) 2))  "WAVE" "fmt " 16 1 1 sampling-rate (* 2 sampling-rate) 2 16
                     "data" (* (length wave-data) 2) (s8vector->string (uvector-alias <s8vector> pcm-data)))
               :to-string? #t))
      (s16vector-set! pcm-data i (round->exact (* 32767 (or (car rest) 0)))))))

;; 波形データを生成します。
;;  sampling-rate: サンプリングレート
;;  wave-form: -1から1の要素を持つベクトル。矩形波だと#(1 -1)のようになります。
;;  freq: 周波数
;;  sec: 秒数
;;  戻り値: 波形データ
(define (oscillator sampling-rate wave-form freq sec)
  (define (amplitude l)
    (vector-ref wave-form
                (round->exact (* (- (vector-length wave-form) 1)
                                 (* (- l (floor->exact l)))))))
  (let ((len (floor->exact (* sampling-rate sec))))
    (do ((i 0 (+ i 1))
         (wave-data '()
                    (cons (and freq (amplitude (* freq (/ (* i sec) len))))
                          wave-data)))
        ((<= len i) (reverse wave-data)))))

;; 音階を与えて、波形データを生成します。
;;  sampling-rate: サンプリングレート
;;  p: ピッチ。O4のドを60とした数値。1オクターブ12音なので、O5のドだと72になります。
;;  sec: 秒数
;;  キーワード引数として、:wave-form 波形データ をとります。
;;  戻り値: 波形データ
(define (pitch sampling-rate p sec . opts)
  (let-optionals* opts ((wave-form #(1 -1)))
    (oscillator sampling-rate wave-form (and p (* 440 (expt 2 (/ (- p 69) 12)))) sec)))

;; エンベロープのパラメータを与えて、波形データを変化させます。
;;  env-param: ベクトルで、アタックタイム、ディレイタイム、サステインレベル、リリースタイムを順に含みます。1で正規化しておいてください。
;;  wave-data: 入力の波形データ
;;  戻り値: 変化した波形データ
(define (envelope env-param wave-data)
  (let* ((len (length wave-data))
         (ta (* len (vector-ref env-param 0)))
         (td (* len (vector-ref env-param 1)))
         (ls (vector-ref env-param 2))
         (tr (* len (vector-ref env-param 3))))
    (define (make-func a b limit cont)
      (letrec ((f (lambda (new rest i)
                    (if (or (null? rest) (<= limit i))
                        (cont new rest i)
                        (f (cons (* (+ (* a i) b) (car rest)) new) (cdr rest) (+ i 1))))))
        f))
    (((compose (cut make-func (/ 1 ta) 0 ta <>)
               (cut make-func (/ (- ls 1) td) (+ 1 (/ (* ta (- 1 ls)) td)) (+ ta td) <>)
               (cut make-func 0 ls (- len tr) <>)
               (cut make-func (/ (- ls) tr) (/ (* len ls) tr) len <>))
      (lambda (new rest i) (reverse new)))
     '() wave-data 0)))

;; 複数の波形データを合成します。和音をを作るときに使用します。
;;  wave-data-list: 波形データのリスト
;;  戻り値: 合成された波形データ
(define (merge-wave wave-data-lst)
  (apply map (lambda amps
               (call-with-values (cut fold2 (lambda (a s c)
                                              (if a
                                                  (values (+ s a) (+ c 1))
                                                  (values s c)))
                                      0 0 amps)
                 (lambda (x y)
                   (if (= y 0)
                       0
                       (/ x y)))))
         wave-data-lst))

;; 複数の波形データを連結します。
;;  wave-data-list: 波形データのリスト
;;  戻り値: 連結された波形データ
(define (concat-wave wave-data-lst)
  (apply append wave-data-lst))

;; MML(Music Macro Language)から、波形データを生成します。
;;  sampling-rate: サンプリングレート
;;  expr: 昔のN88-BASIC風のMMLです。(c 4) で4分音符のドになります。(o 4) でオクターブの指定、(r 4)で休符になります。これらをリストで与えてください。
;;  キーワード引数として、:tempo テンポ、:wave-form 波形データ、:envelope エンベロープパラメータ をとります。
;;  戻り値: 波形データ
(define (mml->wave sampling-rate expr . opts)
  (let-keywords opts ((tempo 120)
                      (wave-form #(1 -1))
                      (env :envelope #f))
    (let ((filter (if env (cut envelope env <>) values))
          (l->sec (lambda (l) (/ 240 (* tempo l))))
          (note-alist (apply append (map (lambda (lst n)
                                           (map (cut cons <> n) lst))
                                         '((c) (c+ d-) (d) (d+ e-) (e) (f) (f+ g-) (g) (g+ a-) (a) (a+ b-) (b))
                                         (iota 12)))))
      (let loop ((expr expr)
                 (octave 5)
                 (waves '()))
        (match expr
          (() (concat-wave (reverse waves)))
          ((('r l) rest ...) (loop rest octave (cons (pitch #f (l->sec l)) waves)))
          ((('o n) rest ...) (loop rest (+ n 1) waves))
          (((note l) rest ...) (loop rest
                                     octave
                                     (cons (filter (pitch sampling-rate (+ (* 12 octave) (cdr (assq note note-alist)))
                                                          (l->sec l)
                                                          wave-form))
                                           waves))))))))

;; MML(Music Macro Language)から、wavデータを生成します。MMLは複数指定でき、それらは合成されるので、和音も出せます。
;;  mml-list: MMLのリスト。
;;  キーワード引数として、:tempo テンポ、:wave-form 波形データ、:envelope エンベロープパラメータ、:sampling-rate サンプリングレート をとります。
;;  戻り値: wavデータの不完全文字列
(define (mml->riff mml-list . opts)
  (let-keywords opts ((sampling-rate 44100)
                      . rest)
    (wave->riff sampling-rate (merge-wave (map (lambda (mml)
                                                 (apply mml->wave sampling-rate mml rest))
                                               mml-list)))))
    
;;;; end of synthesizer

;;;;
;;;; quiz module
;;;; 英単語辞書操作用API
;;;;

(define-module quiz
  (use srfi-1)
  (use srfi-11)
  (use util.match)
  (use util.list)

  (export load-quizzes save-quizzes quiz-word quiz-meaning update-answer make-ranking add-new-word make-order)
  )

(select-module quiz)

;; 辞書ファイルの形式Dは
;; W := (word meaning) | (word meaning ok-count ng-count)
;; D := (W ...)

;; load-quizzes: 辞書ファイルのパス(文字列) -> 問題リスト
(define (load-quizzes file)
  (map (match-lambda
        ((word mean)
         (list (x->string word) (x->string mean) 0 0))
        ((word mean ok ng)
         (list (x->string word) (x->string mean) (x->integer ok) (x->integer ng))))
       (let/cc break
	 (call-with-input-file file
	   (lambda (port)
	     (if port
		 (read port)
		 (break '())))
	   :if-does-not-exist #f))))

;; save-quizzes: 辞書ファイルのパス(文字列) -> 問題リスト -> #t
(define (save-quizzes file quizzes)
    (call-with-output-file file (cut write quizzes <>)))
  
;;quiz-word : 問題リスト -> 問題ID(整数) -> 問題の単語
(define (quiz-word quizzes nth)
  (list-ref (list-ref quizzes nth) 0))

;;quiz-meaning : 問題リスト -> 問題ID(整数) -> 単語の意味
(define (quiz-meaning quizzes nth)
  (list-ref (list-ref quizzes nth) 1))

;;update-answer : 問題リスト -> 問題ID(整数) -> ユーザの答(#t:知っている, #f:知らない) -> 変更後の問題リスト
(define (update-answer quizzes nth answer)
  (let-values (((head tail) (split-at quizzes nth)))
    (append head
            `((,(list-ref (car tail) 0)
               ,(list-ref (car tail) 1)
               ,(+ (list-ref (car tail) 2 0) (if answer 1 0))
               ,(+ (list-ref (car tail) 3 0) (if answer 0 1))))
            (cdr tail))))

;; sort-quizzes : 問題リスト -> 正答率下位順にソートした(正答率 . 問題ID)ペアのリスト
(define (sort-quizzes quizzes)
  (define (correctness ok ng)
    (if (zero? (+ ok ng))
      0
      (/ ok (+ ok ng))))
  (sort-by (let1 index -1
             (map (match-lambda
                   ((word mean ok ng)
                    (inc! index)
                    (cons (correctness ok ng) index)))
                  quizzes))
           car))

;; make-ranking : 問題リスト -> 正答率下位k個(整数)まで -> 正答率下位k個の (単語 . 正答率) のリスト 
(define (make-ranking quizzes k)
  (map (lambda (pair)
         (cons (quiz-word quizzes (cdr pair)) (car pair)))
       (take* (sort-quizzes quizzes) k)))

;; add-new-word : 問題リスト -> 登録する英単語(文字列) -> 登録する英単語の意味(文字列) -> 変更後の問題リスト
(define (add-new-word quizzes word meaning)
  (if (assoc word quizzes)
      quizzes
      (alist-cons word (list meaning 0 0) quizzes)))

;; make-order : 問題リスト -> おすすめの出題順のIDのリスト
(define (make-order quizzes)
  ;;正答率下位から先に出題することをおすすめ
  (map cdr (sort-quizzes quizzes)))

;;;; end of quiz

;;;;
;;;; ここから本体
;;;;
;;;;

(select-module user)

(use gauche.parseopt)
(use rfc.uri)
(use text.html-lite)
(use text.tree)
(use util.list)
(use util.match)

;; 以下のモジュールは同一ファイル内にあるため、useではなくimportで利用を宣言する。
(import webserver)
(import quiz)
(import synthesizer)

(define *quiz-file* #f)

(define *quizzes* '())

(define (json-quiz-list)
  (string-append "["
                 (string-join (map x->string
                                   (make-order *quizzes*)) ",")
                 "]"))

(define (action-problem req-alist)
  (let ((id (string->number (assoc-ref (query-parameter req-alist) "id"))))
    (http-response (tree->string
                    (html:div (html:p "問題")
                              (html:p (format "\"~a\"の意味を知っていますか?" (quiz-word *quizzes* id)))))
                   :Content-Type "text/html")))

(define (action-answer req-alist)
  (let ((id (string->number (assoc-ref (query-parameter req-alist) "id"))))
    (http-response (tree->string
                    (html:div (html:p "答え")
                              (html:p (format "\"~a\"の意味は「~a」です。"
                                              (quiz-word *quizzes* id)
                                              (quiz-meaning *quizzes* id)))))
                   :Content-Type "text/html")))

(define (action-yes req-alist)
  (let ((id (string->number (assoc-ref (query-parameter req-alist) "id"))))
    (set! *quizzes* (update-answer *quizzes* id #t))
    (save-quizzes *quiz-file* *quizzes*)
    (http-response "" :Content-Type "text/html")))

(define (action-no req-alist)
  (let ((id (string->number (assoc-ref (query-parameter req-alist) "id"))))
    (set! *quizzes* (update-answer *quizzes* id #f))
    (save-quizzes *quiz-file* *quizzes*)
    (http-response "" :Content-Type "text/html")))

(define (page-quiz req-alist)
  (http-response
   (tree->string (html:html :lang "ja"
                            (html:head
                             (html:meta :http-equiv "Content-Type"
                                        :content "text/html; charset=utf-8")
                             (html:title "英単語練習"))
                             (html:script :type "text/javascript"
                                          #`"var idList = ,(json-quiz-list);"
"
var currentIndex = 0;
var soundYes = new Audio('/data/yes.wav');
var soundNo = new Audio('/data/no.wav');

function callAPI(name) {
    var req = new XMLHttpRequest();
    req.open('GET', '/api/' + name + '?id=' + idList[currentIndex], false);
    req.send(null);
    return req.responseText;
}    
function displayProblem() {
    document.getElementById('display').innerHTML = callAPI('problem');
    document.getElementById('yes').style.visibility = 'visible';
    document.getElementById('yes').style.width = 200;
    document.getElementById('no').style.visibility = 'visible';
    document.getElementById('no').style.width = 200;
    document.getElementById('next').style.visibility = 'hidden';
    document.getElementById('next').style.width = 0;
}
function answer() {
    document.getElementById('display').innerHTML = callAPI('answer');
    document.getElementById('yes').style.visibility = 'hidden';
    document.getElementById('yes').style.width = 0;
    document.getElementById('no').style.visibility = 'hidden';
    document.getElementById('no').style.width = 0;
    document.getElementById('next').style.visibility = 'visible';
    document.getElementById('next').style.width = 500;
}
function answerYes() {
    if (document.getElementById('yes').style.visibility == 'hidden') {
        return;
    }
    callAPI('yes');
    soundYes.play();
    answer();
}
function answerNo() {
    if (document.getElementById('no').style.visibility == 'hidden') {
        return;
    }
    callAPI('no');
    soundNo.play();
    answer();
}
function nextQuiz() {
    if (document.getElementById('next').style.visibility == 'hidden') {
        return;
    }
    ++currentIndex;
    if (currentIndex < idList.length) {
        displayProblem();
    } else {
        document.location = 'ranking.html';
    }
}
function dispatch(event) {
    if (event.charCode == 89 || event.charCode == 121) { 
        answerYes(); 
    } else if (event.charCode == 78 || event.charCode == 110) { 
        answerNo(); 
    } else if (event.charCode == 32) { 
        nextQuiz(); 
    }
}
")
                            (html:body :onload "displayProblem()"
                                       :onkeypress "dispatch(event)"
                             (html:div :id "display" :style "border-style:solid;border-width:2px;border-color:#0000FF;background-color:#000070;color:#FFFFFF;width:500px;height:200px;font-size:x-large;text-align:center;")
                             (html:div :style "width:502px;"
                                       (html:div :id "yes" :style "border-style:solid;border-width:2px;border-color:#00FF00;background-color:#007000;color:#FFFFFF;visibility:hidden;width:200px;font-size:xx-large;text-align:center;float:left;" :onclick "answerYes()" "知っている(y)")
                                       (html:div :id "no" :style "border-style:solid;border-width:2px;border-color:#FF0000;background-color:#700000;color:#FFFFFF;visibility:hidden;width:200px;font-size:xx-large;text-align:center;float:right;" :onclick "answerNo()" "知らない(n)"))
                             (html:div :id "next" :style "border-style:solid;border-width:2px;border-color:#00FFFF;background-color:#007070;color:#FFFFFF;width:500px;font-size:xx-large;text-align:center;visibility:hidden" :onclick "nextQuiz()" "次の問題(スペース)"))))
   :Content-Type "text/html"))

(define (page-ranking req-alist)
  (http-response (tree->string 
                  (html:html :lang "ja"
                             (html:head
                              (html:meta :http-equiv "Content-Type"
                                         :content "text/html; charset=utf-8")
                              (html:title "正答率ランキング(ワースト5)"))
                             (html:body
                              (html:h1 "正答率ランキング(ワースト5)")
                              (html:table
                               (html:tr (html:td "単語") (html:td "正答率(%)"))
                               (map (lambda (pair)
                                      (html:tr (html:td (car pair))
                                               (html:td (round->exact (* 100 (cdr pair))))))
                                    (make-ranking *quizzes* 5)))
                              (html:a :href "/quiz.html" "もう一度挑戦する"))))
                 :Content-Type "text/html"))

(define (data-yes-sound req-alist)
  (http-response (mml->riff '(((o 6) (e 8) (c 8) (e 8) (c 2)))
                            :tempo 240 :wave-form #(0 0.5 1 -1 -0.5) :envelope #(0 0.1 0.5 0.6))
                 :Content-Type "audio/wav"))

(define (data-no-sound req-alist)
  (http-response (mml->riff '(((o 2) (c 8) (c 2))) :tempo 240 :envelope #(0 0 1 0.05))
                 :Content-Type "audio/wav"))

(register-action! "GET" "/api/problem" action-problem)
(register-action! "GET" "/api/answer" action-answer)
(register-action! "GET" "/api/yes" action-yes)
(register-action! "GET" "/api/no" action-no)
(register-action! "GET" "/quiz.html" page-quiz)
(register-action! "GET" "/ranking.html" page-ranking)
(register-action! "GET" "/data/yes.wav" data-yes-sound)
(register-action! "GET" "/data/no.wav" data-no-sound)

(define (main args)
  (let-args (cdr args) ((dict-file "f|dict-file=s" "words.txt")
                        (port "p|port=i" #f)
                        (help "h|help" => (cut usage (car args))))
    (set! *quiz-file* dict-file)
    (set! *quizzes* (load-quizzes *quiz-file*))
    (if port
        (if (< 0 (length *quizzes*))
            (begin
              (print "*** 英単語練習モード ***")
              (format #t "http://localhost:~d/quiz.html にアクセスしてください。~%" port)
              (start-webserver! port))
            (print "単語が登録されていないので、テストできません。"))
        (begin
          (print "*** 単語登録モード ***")
          (format #t "単語と意味を半角 = で区切って入力(例：apple=林檎)してください．：")
          (flush-all-ports)
          (port-for-each (lambda (line)
                           (match (string-split line "=")
                             ((w m)
                              (set! *quizzes* (add-new-word *quizzes* w m))
                              (save-quizzes *quiz-file* *quizzes*))
                             (else
                              (format #t "指定が間違っています。~%")))
                           (format #t "単語と意味を半角 = で区切って入力(例：apple=林檎)してください．：")
                           (flush-all-ports))
                         read-line)))
    0))

(define (usage prognam)
  (format #t "Usage: ~a [options]~%" prognam)
  (print "Options:")
  (print "  -f, --dict-file=FILE  : 辞書ファイルの指定。省略時は words.txt となります。")
  (print "  -p, --port=PORT       : ポート番号の指定。省略すると単語登録モードになります。")
  (print "  -h, --help            : 使い方を表示します。")
  (exit 1))

;; -*- coding: utf-8; mode: scheme -*-
;; end of file