scheme_baton.scm

;; 第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. garaemon (http://garaemon.net/): コマンドラインオプションを追加. srfi 37を利用.
;; =================================================================================================================================================
;;                            これより下がコードとその説明 - 変更・削除歓迎
;; =================================================================================================================================================

;; ■英単語暗記補助ツールです
;;   起動すると辞書ファイルから単語が表示されるので意味を頭で考えます。Ctrl-D を押すと答えが表示されます。 (y/n) を聞かれるので正解なら y を押してください。
;;   間違った単語は辞書ファイルに記録され次回出題されます。
;;
;; ■動作方法
;;   Mosh (0.2.0) で動作します。(http://code.google.com/p/mosh-scheme/downloads/list)
;;   % mosh scheme_button.scm -f=辞書ファイル
;; ■helpの表示
;;   % mosh scheme_button.scm -h
;; ■辞書ファイルの例
;;   http://gist.github.com/273424

(import (rnrs)
        (mosh control)
        (mosh)
        (match)
        (srfi :8)
        (srfi :37)                      ;for parsing arguments
        (only (srfi :1) first second take drop))

;; ファイルを読んで S 式のリストにする
(define (file->sexp-list file)
  (with-input-from-file file
    (lambda ()
      (let loop ([line (read)]
                 [ret '()])
        (cond
         [(eof-object? line) (reverse ret)]
         [else
          (loop (read) (cons line ret))])))))

;; 辞書ファイルをパース
(define (sort-word-spec* word-spec*)
  (list-sort
   ;; 間違いが多い順にソート
   (lambda x
     (match x
            [((_a _b ok-count1 ng-count1) (_c _d ok-count2 ng-count2))
             (> (- ng-count1 ok-count1) (- ng-count2 ok-count2))]))
   ;; 辞書形式は (word meaning) または (word meaning ok-count ng-count)
   (map (lambda (word-spec*)
          (match word-spec*
                 [(word meaning)
                  (list word meaning 0 0)]
                 [(word meaning ok-count ng-count)
                  (list word meaning ok-count ng-count)]))
        word-spec*)))

;; parsing arguments, for checking options in command-line
(define (replace-list-index lst index elt)
  (append (take lst index) (cons elt (drop lst (+ index 1)))))

(define (options-list->option-objects lst)
  ;; lst = options
  ;; options := (option)
  ;; option := (match-str default-value take-arg?)
  (let loop ((rest lst)
             (index 0))
    (if (null? rest)
        '()
      (let* ((target (car rest))
             (match-str (car target))
             (default-value (cadr target))
             (take-arg? (caddr target)))
        (cons
         (option match-str #f take-arg?
                 (lambda (option name arg . rest)
                   (apply values
                          (replace-list-index rest index
                                              (if take-arg? arg #t)))))
         (loop (cdr rest) (+ 1 index)))))))

(define-syntax with-parsed-options
  (syntax-rules ()
    ((_ (params ...) options arg bodies ...)
     (receive (params ...)
       (parse-args arg options)
       bodies ...))))

(define (parse-args args args-options)
  (apply args-fold args
         ;; options
         (options-list->option-objects args-options)
         ;; for unkown oarams
         (lambda (option name arg . rest)
           (error "Unkown option: " name))
         (lambda (op . rest)
           (apply values rest))
         (map cadr args-options)))

(define *arg-options*
  '(((#\d "debug")                      ;match string or character
     #f                                 ;default value
     #f)                                ;take value or not
    ((#\v "verbose")
     #f
     #f)
    ((#\f "dict-file")
     "words.txt"
     #t)
    ((#\h "help")
      #f
      #f)))

(define (repl-loop dict-file verbose?)
  (let1 result*
        (call/cc
         (lambda (break)
           (let loop ([word-spec* (sort-word-spec*
                                   (file->sexp-list dict-file))]
                      [result-spec* '()])
             (match word-spec*
                    [() result-spec*]
                    [((word meaning ok-count ng-count) . more)
                     ;; 問題出題
                     (format #t "~s: " word)
                     ;; Ctrl-D 待ち
                     (read (current-input-port))
                     ;; 答え表示
                     (format #t "~s y/n? " meaning)
                     (case (read-char (current-input-port))
                       ;; Y だったら
                       [(#\y #\Y)
                        (loop more
                              (cons (list word meaning (+ ok-count 1) ng-count)
                                    result-spec*))]
                       ;; N だったら
                       [(#\N #\n)
                        (loop more (cons (list word meaning ok-count
                                               (+ ng-count 1))
                                         result-spec*))]
                       ;; Q だったら途中でやめるので成績を記録
                       [(#\q #\Q)
                        (break (append (reverse result-spec*)
                                       word-spec*))])])]))
        ;; 正答と誤答を記録
        (save-result result* dict-file verbose?)
        #t))

(define (save-result result dict-file verbose?)
  (when verbose?
    (format #t "now saving result to ~A~%" dict-file))
  (call-with-port
   (open-file-output-port dict-file
                          (make-file-options '(no-fail))
                          'block (native-transcoder))
   (lambda (p)
     (for-each (lambda (x)
                 (write x p)
                 (newline p)) result)))
  #t)

(define (usage)
  (format #t "usage: mosh scheme_baton.scm [OPTIONS]... ~%")
  (format #t "this is a program to support memorizing the english format.~%")
  (format #t "and, this program may be presented in the next shibuya.lisp technical talk~%")
  (format #t "the latest code is avaiable on http://gist.github.com/273431~%")
  (format #t "this program is written in scheme(R6RS) and works on mosh.~%")
  (format #t "~%")
  (format #t "  -d, --debug           debug option.~%")
  (format #t "  -v, --verbose         work with verbosing mode.~%")
  (format #t "  -f, --dict-file=FILE  specify the dictionaly file.~%")
  (format #t "                        the default value is words.txt ~%")
  (format #t "  -h, --help            print this documentation.~%")
  #t)

(define (main args)
  (with-parsed-options
   (debug? verbose? dict-file help?)
   *arg-options* args
   (when (or verbose? debug?)
     (format #t "arguments => ~A~%" args)
     (format #t "debug? => ~A~%" debug?)
     (format #t "verbose? => ~A~%" verbose?)
     (format #t "dict-file => ~A~%" dict-file)
     (format #t "help? => ~A~%" help?))
   (if help?
       (usage)
     (repl-loop dict-file verbose?))
   ))

(main (command-line))