masaedw/scheme_baton.scm

## 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. 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)


;; =================================================================================================================================================
;;                            これより下がコードとその説明 - 変更・削除歓迎
;; =================================================================================================================================================

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

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

;; ファイルを読んで 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 *libncurses* (open-shared-library "libncursesw.so"))
(define initscr (c-function *libncurses* void* initscr))
(define cbreak (c-function *libncurses* int cbreak))
(define noecho (c-function *libncurses* int noecho))
(define getch (c-function *libncurses* int getch))
(define endwin (c-function *libncurses* int endwin))
(define move (c-function *libncurses* int move int int))
(define addstr (c-function *libncurses* int addstr void*))

;(import (srfi :1) (mosh ffi))
(define *libc* (open-shared-library "libc.so.6"))
(define malloc (c-function *libc* void* malloc int)) ;なぜかffi組み込みのmallocが呼べませんでした
(define setlocale (c-function *libc* void* setlocale int void*))
(define LC_ALL 6)                       ; !!環境依存!!

;; Scheme文字列からC文字列を得る
(define (string->pointer str)
  (let* ([u8 (string->utf8 str)]
         [len (bytevector-length u8)]
         [ptr (malloc (+ len 1))]
         [index (iota len 0)])
    (map (lambda (i c)
           (pointer-set-c-uint8! ptr i c))
         index (bytevector->u8-list u8))
    (pointer-set-c-uint8! ptr len 0)
    ptr))

(define (repl-loop dict-file verbose?)
  (define result
    (begin
      ;; 端末を設定
      (setlocale LC_ALL (string->pointer ""))
      (initscr)
      (noecho)
      (cbreak)

      (let loop ([word-spec* (sort-word-spec*
                              (file->sexp-list dict-file))]
                 [result-spec* '()]
                 [y-index 0])
        (match word-spec*
          [() result-spec*]
          [((word meaning ok-count ng-count) . more)
           ;; 問題出題
           (move y-index 0)
           (addstr (string->pointer (format "~s: " word)))
           ;; 何かキーが押されるのを待つ
           (getch)
           ;; 答え表示
           (addstr (string->pointer (format "~s y/n? " meaning)))
           (case (integer->char (getch))
             ;; Y だったら
             [(#\Y #\y)
              (loop more
                    `((,word ,meaning ,(+ ok-count 1) ,ng-count)
                      ,@result-spec*)
                    (+ y-index 1))]
             ;; N だったら
             [(#\N #\n)
              (loop more
                    `((,word ,meaning ,ok-count ,(+ ng-count 1))
                      ,@result-spec*)
                    (+ y-index 1))]
             ;; Q だったら途中でやめる
             [(#\q #\Q)
              (append-reverse result-spec*
                              word-spec*)]
             ;; その他だったら何もせずに次にいく
             [else
              (loop more
                    `((,word ,meaning ,ok-count ,ng-count)
                      ,@result-spec*)
                    (+ y-index 1))])]))))

  (endwin)
  ;; 正答と誤答を記録
  (save-result result dict-file verbose?))

(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/275132~%")
  (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 *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 (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?))
   (exit 0)))

(main (command-line))
	;; 第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)


	;; =================================================================================================================================================
	;; これより下がコードとその説明 - 変更・削除歓迎
	;; =================================================================================================================================================

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

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

	;; ファイルを読んで 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 libncurses (open-shared-library "libncursesw.so"))
	(define initscr (c-function libncurses void* initscr))
	(define cbreak (c-function libncurses int cbreak))
	(define noecho (c-function libncurses int noecho))
	(define getch (c-function libncurses int getch))
	(define endwin (c-function libncurses int endwin))
	(define move (c-function libncurses int move int int))
	(define addstr (c-function libncurses int addstr void*))

	;(import (srfi :1) (mosh ffi))
	(define libc (open-shared-library "libc.so.6"))
	(define malloc (c-function libc void* malloc int)) ;なぜかffi組み込みのmallocが呼べませんでした
	(define setlocale (c-function libc void* setlocale int void*))
	(define LC_ALL 6) ; !!環境依存!!

	;; Scheme文字列からC文字列を得る
	(define (string->pointer str)
	(let* ([u8 (string->utf8 str)]
	[len (bytevector-length u8)]
	[ptr (malloc (+ len 1))]
	[index (iota len 0)])
	(map (lambda (i c)
	(pointer-set-c-uint8! ptr i c))
	index (bytevector->u8-list u8))
	(pointer-set-c-uint8! ptr len 0)
	ptr))

	(define (repl-loop dict-file verbose?)
	(define result
	(begin
	;; 端末を設定
	(setlocale LC_ALL (string->pointer ""))
	(initscr)
	(noecho)
	(cbreak)

	(let loop ([word-spec* (sort-word-spec*
	(file->sexp-list dict-file))]
	[result-spec* '()]
	[y-index 0])
	(match word-spec*
	[() result-spec*]
	[((word meaning ok-count ng-count) . more)
	;; 問題出題
	(move y-index 0)
	(addstr (string->pointer (format "~s: " word)))
	;; 何かキーが押されるのを待つ
	(getch)
	;; 答え表示
	(addstr (string->pointer (format "~s y/n? " meaning)))
	(case (integer->char (getch))
	;; Y だったら
	[(#\Y #\y)
	(loop more
	`((,word ,meaning ,(+ ok-count 1) ,ng-count)
	,@result-spec*)
	(+ y-index 1))]
	;; N だったら
	[(#\N #\n)
	(loop more
	`((,word ,meaning ,ok-count ,(+ ng-count 1))
	,@result-spec*)
	(+ y-index 1))]
	;; Q だったら途中でやめる
	[(#\q #\Q)
	(append-reverse result-spec*
	word-spec*)]
	;; その他だったら何もせずに次にいく
	[else
	(loop more
	`((,word ,meaning ,ok-count ,ng-count)
	,@result-spec*)
	(+ y-index 1))])]))))

	(endwin)
	;; 正答と誤答を記録
	(save-result result dict-file verbose?))

	(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/275132~%")
	(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 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 (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?))
	(exit 0)))

	(main (command-line))