scheme_baton.scm

#!/usr/local/bin/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)
 
;; =================================================================================================================================================
;;                            これより下がコードとその説明 - 変更・削除歓迎
;; =================================================================================================================================================

;; ■英単語暗記補助CGI
;;   5種類のWeb APIを提供します。レスポンスはXMLです。
;;   word.cgi?q=3              IDが3の問題データ
;;   word.cgi?q=3&a=y          IDが3の問題データの正答率を更新する
;;   word.cgi?r=5              正答率下位5個の問題ランキングデータ
;;   word.cgi?w=apple&m=ringo  英単語apple、その意味ringoを、辞書に追加する
;;   word.cgi                  おすすめの出題順をカンマ区切りで
;; ■辞書ファイルの指定
;;   クエリパラメタfで辞書ファイルを指定できます。
;;   word.cgi?f=words2.txt     words2.txtというファイルを辞書ファイルとして使う
;; ■動作方法
;;   Gauche (0.9) で動作します。(http://practical-scheme.net/gauche/index-j.html)
;;   デフォルトの辞書ファイルはwords.txtというファイル名で、CGIと同じファイルパスに置いてください。
;;
;; ■辞書ファイルの例
;;   http://gist.github.com/285224

(use srfi-1)
(use srfi-13)
(use util.list)
(use util.match)
(use sxml.sxpath)
(use www.cgi)
(use www.cgi.test)
(use text.tree)
(use text.html-lite)
(use sxml.serializer)
(use gauche.parameter)
(use gauche.sequence)

;; 辞書ファイルのパス(文字列)
(define-constant default-quizzes-file "words.txt")
(define quizzes-file (make-parameter default-quizzes-file))

;; 辞書ファイルに登録できる英単語の上限(整数)
(define-constant quizzes-max-limit 500)

;; SXMLをXMLに変換してCGIの出力にする
(define (cgi-output-sxml->xml sxml)
  (write-tree `(,(cgi-header :content-type "text/xml")))
  (srl:parameterizable
   sxml
   (current-output-port)
   '(method . xml)               ; XML
   '(indent . #f)                ; no indent
   '(omit-xml-declaration . #f)  ; append the XML declaretion
   '(standalone . yes)           ; add "standalone" declaretion
   '(version . "1.0")))

;; 例外メッセージをSXMLにする
(define (cgi-on-error e)
  `(error ,(html-escape-string (slot-ref e 'message))))

;; 英単語練習出題側手続
(define (quizz-main params)
  (let1 quizzes (load-quizzes (quizzes-file))
    ;; クエリパラメータ
    ;; q は問題ID(整数)
    ;; a はユーザの答(文字列)
    ;; r は正答率下位r個(整数)
    ;; w は単語(文字列)
    ;; m は意味(文字列)
    ;; f はファイル名(文字列; デフォルト: words.txt)
    (or (and-let* ((q (cgi-get-parameter "q" params :convert x->integer)))
          (or (and-let* ((a (cgi-get-parameter "a" params)))
                ;; q&aのとき、問題へのユーザの答を辞書ファイルに記録する
                (save-answer quizzes q a))
              ;; qのとき、問題を返す
              (make-quiz quizzes q)))
        (and-let* ((r (cgi-get-parameter "r" params :convert x->integer)))
          ;; rのとき、正答率下位r個のランキングを返す
          (make-ranking quizzes r))
        ;; w&m のとき、新しい英単語とその意味を辞書ファイルに追加する
        (and-let* ((w (cgi-get-parameter "w" params))
                   (m (cgi-get-parameter "m" params)))
          (add-new-word quizzes w m))
        ;; 何もないとき、おすすめの出題順を返す
        (make-order quizzes))))

(define (main args)
  (if (cgi-get-metavariable "REQUEST_METHOD") ; CGIとして起動された
      (cgi-main
       (lambda (params)
	 (let1 f (normalize-filename (cgi-get-parameter "f" params :default default-quizzes-file))
	       (parameterize ((quizzes-file f))
			     (quizz-main params))))
       :output-proc cgi-output-sxml->xml
       :on-error cgi-on-error
       )
      (client-main args)
      ))

;; 辞書ファイルの形式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))))

;;make-quiz : 問題リスト -> 問題ID(整数) -> 問題データのSXML
(define (make-quiz quizzes nth)
  (guard (e (else `(quiz (word "undefined") (mean "undefined"))))
    (match (list-ref quizzes nth)
           ((word mean ok ng)
            `(quiz (@ (id ,nth))
                   (word ,word)
                   (mean ,mean)
                   (ok   ,ok)
                   (ng   ,ng))))))

;;save-answer : 問題リスト -> 問題ID(整数) -> ユーザの答(文字列) -> <success/>のSXML
(define (save-answer quizzes nth answer)
  (guard (e (else `(failure)))
    (let1 e (list-ref quizzes nth)
      (match e
	((word mean ok ng)
	 (case (string->symbol answer)
	   ((y Y) (inc! (ref e 2)))
	   ((n N) (inc! (ref e 3)))))))
    ;; 正答と誤答をファイルに書き込んで記録
    (call-with-output-file (quizzes-file) (cut write quizzes <>))
    '(success)))

;; 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個のランキングのSXML
(define (make-ranking quizzes k)
  `(ranking (@ (r ,k))
    ,@(if (negative? k)
       '()
       (map (lambda (x)
              (make-quiz quizzes (cdr x)))
            (take* (sort-quizzes quizzes) k)))))

;; add-new-word : 問題リスト -> 登録する英単語(文字列) -> 登録する英単語の意味(文字列) -> <success/>のSXML
(define (add-new-word quizzes word meaning)
  (guard (e (else `(failure ,(slot-ref e 'message))))
    ;; 登録数を制限する
    (cond ((>= (length quizzes) quizzes-max-limit) '(failure (toomanywords)))
	  ;; 3文字以上の英単語しか認めない
	  ((and-let* ((mat (#/\w{3,}/ word))) (mat)) =>
	   (lambda (word)
	     ;; 16文字未満の英単語の意味しか認めない
	     (cond ((<= 16 (string-length meaning)) '(failure (toolongmeaning)))
		   ;; 既に登録済みの英単語は認めない
		   ((any (lambda (x)
			   (string=? (car x) word))
			 quizzes)
		    '(failure (notuniqueword)))
		   (else
		    (call-with-output-file (quizzes-file)
		      (lambda (out)
			(write (reverse! (cons (list word meaning) (reverse quizzes))) out)))
		    '(success)))))
	  (else '(failure (irregularword))))))

;; make-order : 問題リスト -> おすすめの出題順のSXML
(define (make-order quizzes)
  ;;正答率下位から先に出題することをおすすめ
  `(order (@ (len ,(length quizzes)))
     ,(string-join (map (compose x->string cdr) (sort-quizzes quizzes))
                   ",")))

(define (normalize-filename fname)
  (let1 fname (sys-basename fname)
    (if (#/^\w+\.txt$/ fname)
	fname
	default-quizzes-file)))

;; client-main : 英単語練習：利用者側手続
(define (client-main args)
  (receive (script options) (car+cdr args)
    (quiz-standalone script)))

;; quiz-standalone 別途CGI(HTTP)サーバを必要としない英単語練習プログラム
(define (quiz-standalone script)
  (begin
    (format #t "英単語練習(E)？辞書追加(D)？(デフォルト E)：")
    (flush-all-ports)
    (let1 ed (read-line)
      (format #t "辞書ファイルを指定してください．(デフォルト ~a)：" (quizzes-file))
      (flush-all-ports)
      ;; 辞書ファイル設定
      (let1 prev-dict (quizzes-file (read-line))
	(if (string-null? (quizzes-file)) (quizzes-file prev-dict)))
      (if (string-prefix-ci? "d" ed)
	  (expand-dict script)
	  (begin
	    ;; 出題，応答回収，正当数更新
	    (receive (_ content)
              (run-cgi-script->sxml script :environment '((REQUEST_METHOD . "GET"))
	                                   :parameters `((f . ,(quizzes-file))))
	      (for-each (quiz script) 
			(string-split (sxml:string-value (caddr content)) ",")))
            ;; これまでの成績ワースト５の表示
            (format #t "これまでの成績ワースト５~%")
	    (receive (_ content)
              (run-cgi-script->sxml script :environment '((REQUEST_METHOD . "GET"))
	                                   :parameters `((r . 5)
							 (f . ,(quizzes-file))))
	      (let1 ranks (cddr (caddr content))
		(for-each show-record ranks))))))))

(define (quiz script) ; スクリプト名 -> (問題ID -> 出題，応答回収，正当数更新)
  (lambda (id)
    (receive (_ content)
	     (run-cgi-script->sxml script :environment '((REQUEST_METHOD . "GET"))
		                          :parameters `((q . ,id) (f . ,(quizzes-file))))
      (let* ((qdata (cddr (caddr content)))
	     (word (car (assq-ref qdata 'word)))
	     (mean (car (assq-ref qdata 'mean))))
	(run-cgi-script->sxml script 
	    :environment '((REQUEST_METHOD . "GET"))
	    :parameters `((q . ,id)
			  (a . ,(question word mean))
			  (f . ,(quizzes-file))))))))

;; 出題と応答回収
(define (question word mean)
  (begin 
    (format #t "~s の意味は「~a」です．知ってました？(yes/no) : " word mean)
    (flush-all-ports)
    (if (string-prefix-ci? "y" (read-line)) "y" "n")
    ))

;; 辞書の拡張
(define (expand-dict script)
  (begin
    (format #t "単語と意味を半角 = で区切って入力(例：apple=林檎)してください．：")
    (flush-all-ports)
    (let1 rl (read-line)
      (match (string-split rl "=")
       ((w m) (begin (run-cgi-script->sxml script 
		       :environment '((REQUEST_METHOD . "GET"))
		       :parameters `((w . ,w)
				     (m . ,m)
				     (f . ,(quizzes-file))))
		     (expand-dict script)))
       (_ (values))))))

;; show-record 単語の正答率
(define (show-record rec)
  (match rec
    ((_ _ (_ w) (_ m) (_ ok) (_ ng))
     (let* ((nok (string->number ok))
            (nng (string->number ng))
            (ttl (+ nok nng)))
       (format #t "~a ~a : ~a%~%" w m (quotient (* nok 100) ttl))))))