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 で変更したファイルを貼り付けます。
;;        または、git cloneしてgit commitしてgit pushします。
;;    (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)

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

;; ■英単語暗記補助ツールです
;;   起動すると辞書ファイルから単語が表示されるので意味を頭で考えます。何かキーを押すと答えが表示されます。 (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 ffi)
        (match)
        (only (srfi :1 lists)
              append-reverse iota
              unfold alist-cons fifth)
        (srfi :19)
        (srfi :37 args-fold)
        (srfi :39 parameters)
        (srfi :48 intermediate-format-strings)
        (srfi :78 lightweight-testing)
        )

(define *gist-url* "http://gist.github.com/278675")
(define *date-number*
  (string->number
   (date->string (current-date) "~Y~m~d")))

(define (port->list reader port)
  (let ((read-fn (lambda _ (reader port))))
    (unfold eof-object? values read-fn (read-fn))))

(define (word-spec word meaning ok ng date)
  (list word meaning ok ng date))
(define word-spec-word car)
(define word-spec-meaning cadr)
(define word-spec-ok caddr)
(define word-spec-ng cadddr)
(define word-spec-date fifth)

(define (word-spec-incr-ok spec)
  (match spec
    ((w m ok ng date)
     (word-spec w m (+ ok 1) ng date))))

(define (word-spec-incr-ng spec)
  (match spec
    ((w m ok ng date)
     (word-spec w m ok (+ ng 1) date))))

(define (word-spec-update-date spec)
  (match spec
    ((w m ok ng date)
     (word-spec w m ok ng *date-number*))))

(define (load-word-spec* port)
  (define (normalize-word-specs specs)
    (map (lambda (spec)
           (match spec
             ((word meaning)
              (word-spec word meaning 0 0 0))
             ([and spec (word meaning ok ng date)]
              spec)))                       ; as is
         specs))
  (normalize-word-specs
   (port->list read port)))

(define (save-word-spec* specs port)
  (for-each
   (lambda (spec)
     (write spec port)
     (newline port))
   specs))

(define (word-spec-mismatch spec)
  (- (word-spec-ng spec)
     (word-spec-ok spec)))

(define (word-spec-sort-criteria spec)
  (+ (word-spec-date spec)
     (word-spec-mismatch spec)))

(define (list-sort-by key-fn cmp xs)
  ;; decorate-sort-undecorate (aka Schwartzian transform)
  (map cdr
       (list-sort (lambda (a b)
                    (cmp (car a) (car b)))
                  (map (lambda (x)
                         (cons (key-fn x) x))
                       xs))))

(define-syntax swap!
  (syntax-rules ()
    ((_ a b)
     (let ((tmp a))
       (set! a b)
       (set! b tmp)))))

;;; command-line parsing stuff
;;; usage:
#;
(with-parsed-options (cdr (command-line))
    (;; (name (short-option long-option) take-argument? default-value)
     (help (#\h "help") #f #f)
     )
    argv                                ; bound to rest args
  (when ($$ help)                       ; option can be accessed as ($$ name)
    ...)
  ...)
;;; (put 'with-parsed-options 'scheme-indent-function 3)

(define-syntax with-parsed-options
  (syntax-rules ()
    ((_ args spec argv body ...)
     (%with-parsed-options
      spec () '() args argv body ...))))

(define-syntax %with-parsed-options
  (syntax-rules ()
    ((_ () (opts ...) seed args argv body ...)
     (let-values (([alis argv]
                   (args-fold args
                              (list opts ...)
                              (lambda (opt name arg . _)
                                (error 'with-parsed-options
                                       "Unknown option: " name))
                              (lambda (operand alis argv)
                                (values alis (cons operand argv)))
                              seed '())))
       (let ((argv (reverse argv)))
         (parameterize ((*command-line-options* alis))
           body ...))))
    ((_ ((name (short long) req? default) rest ...) (opts ...)
        seed args argv body ...)
     (%with-parsed-options
      (rest ...)
      ((option '(short long) req? #f
               (lambda (opt n arg alis vs)
                 (values (alist-cons 'name (if req? arg #t) alis) vs)))
       opts ...)
      (cons (cons 'name default) seed)
      args argv body ...))))

(define *command-line-options* (make-parameter #f))

(define-syntax $$
  (syntax-rules ()
    ((_ name) (%getopt 'name))))

(define (%getopt name)
  (cond
   ((*command-line-options*)
    => (lambda (alis)
         (cond ((assoc name alis) => cdr)
               (else (error 'getopt "unknown option" name)))))
   (else
    (error 'getopt "command line option have not be parsed"))))

;;端末制御
(define *libncurses* (open-shared-library (find-shared-library #/libncursesw\./)))
(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*))
(define timeout (c-function *libncurses* void timeout int))

(define *libc* (open-shared-library (find-shared-library #/libc\./)))
(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-syntax try-finally
  (syntax-rules ()
    ((_ body cleanup)
     (with-exception-handler
         (lambda (exn)
           cleanup)
       (lambda ()
         (begin0
           body
           cleanup))))))

(define-syntax begin0
  (syntax-rules ()
    ((_ expr body ...)
     (let-values ((res expr))
       body ...
       (apply values res)))))

(define-syntax with-curses
  (syntax-rules ()
    [(_ body)
     (begin
       ;; 端末を設定
       (setlocale LC_ALL (string->pointer ""))
       (initscr)
       (noecho)
       (cbreak)
       (try-finally
        body
        (endwin)))]))

(define (getch-with-timeout n)          ; n はミリ秒
  (with-exception-handler
   (lambda (exn)
     (timeout -1)                       ; 解除
     (raise exn))
   (lambda ()
     (timeout n)
     (let ((c (getch)))
       (timeout -1)                     ; 解除
       c))))

(define (repl specs)
  (let ((question word-spec-word)
        (answer word-spec-meaning))
    (when ($$ reverse)
        (swap! question answer))
    (with-curses
     (let loop ([word-spec* specs]
                [result-spec* '()]
                [y-index 0])
       (cond
        ((null? word-spec*)
         result-spec*)
        (else
         (let ((spec (car word-spec*)))
           ;; 問題出題
           (move y-index 0)
           (addstr (string->pointer (format "~s: " (question spec))))
           ;; 何かキーが押されるのを待つ
           (when (eq? (getch-with-timeout
                       (* (string->number ($$ timeout)) 1000))
                      -1)
                 (addstr (string->pointer (format "Timeout!: ~s"
                                                  (answer spec))))
                 (loop (cdr word-spec*)
                       (cons (word-spec-incr-ng spec) result-spec*)
                       (+ y-index 1)))
           ;; 答え表示
           (addstr (string->pointer (format "~s y/n? " (answer spec))))
           (case (integer->char (getch))
             ;; Y だったら
             [(#\Y #\y)
              (loop (cdr word-spec*)
                    (cons (word-spec-incr-ok spec) result-spec*)
                    (+ y-index 1))]
             ;; N だったら
             [(#\N #\n)
              (loop (cdr word-spec*)
                    (cons (word-spec-update-date
                           (word-spec-incr-ng spec))
                          result-spec*)
                    (+ y-index 1))]
             ;; Q だったら途中でやめる
             [(#\q #\Q)
              (append-reverse result-spec* word-spec*)]
             ;; その他だったら何もせずに次にいく
             [else
              (loop (cdr word-spec*)
                    (cons spec result-spec*)
                    (+ y-index 1))])]))))))

(define (save-result specs dict-file)
  (when ($$ verbose)
    (format #t "now saving result to ~A~%" dict-file))
  (call-with-port
   (open-file-output-port dict-file
                          (file-options no-fail)
                          (buffer-mode block)
                          (native-transcoder))
   (lambda (p)
     (save-word-spec* specs p))))

(define (usage)
  (format #t "usage: mosh scheme_baton.scm [OPTIONS]...
This is a program to support memorizing English words.
And, this program may be presented in the next shibuya.lisp technical talk
The latest code is avaiable on ~A
This program is written in basically vanilla R6RS Scheme
and works on mosh for now.

  -d, --debug           enable debug mode.
  -v, --verbose         enable verbose mode.
  -f, --dict-file=FILE  specify the dictionary file.
                        the default value is words.txt
  -r, --reverse         ask japanese, answer english.
  -t, --timeout=seconds wait answers <seconds> seconds (default: 10).
  -h, --help            print this documentation.
  -T, --test            run self test.
" *gist-url*))


(define (main 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 "reverse => ~A~%" ($$ reverse))
    (format #t "timeout => ~A~%" ($$ timeout))
    (format #t "help? => ~A~%" ($$ help)))
  (if ($$ help)
      (usage)
      (save-result
       (repl (list-sort-by word-spec-sort-criteria >
                           (call-with-input-file ($$ dict-file)
                             load-word-spec*)))
       ($$ dict-file)))
  (exit 0))

(with-parsed-options (cdr (command-line))
    ((debug (#\d "debug") #f #f)
     (verbose (#\v "verbose") #f #f)
     (dict-file (#\f "dict-file") #t "words.txt")
     (reverse (#\r "reverse") #f #f)
     (timeout (#\t "timeout") #t "10")
     (help (#\h "help") #f #f)
     (test (#\T "test") #f #f)
     )
    argv
  (unless ($$ test)
    (main (command-line))))

;;; test goes here
(define (sorted? key-fn cmp xs)
  (or (null? xs)
      (null? (cdr xs))
      (and (cmp (key-fn (car xs))
                (key-fn (cadr xs)))
           (sorted? key-fn cmp (cdr xs)))))

(define-syntax test-sort-sorted
  (syntax-rules ()
    ((_ key-fn cmp xs)
     (check (sorted? key-fn cmp (list-sort-by key-fn cmp xs))
            => #t))))

(check (sorted? values < '()) => #t)
(check (sorted? values < '(1)) => #t)
(check (sorted? values < '(4 3)) => #f)
(check (sorted? values > '(4 3)) => #t)
(test-sort-sorted values < '())
(test-sort-sorted values < '(1))
(test-sort-sorted values < '(4 3 2 1))
(test-sort-sorted abs < '(-1 -3 2 4))
(check (list-sort-by values < '()) => '())
(check (list-sort-by values < '(1)) => '(1))
(check (list-sort-by values < '(4 3 2 1)) => '(1 2 3 4))
(check (list-sort-by abs < '(-1 -3 2 4)) => '(-1 2 -3 4))

(check
 (call-with-port (open-string-input-port "")
   (lambda (p)
     (port->list read p)))
 => '())

(check
 (call-with-port (open-string-input-port "a b c")
   (lambda (p)
     (port->list read p)))
 => '(a b c))

;; save/load invariance
(let ((ws (list (word-spec 'foo 'bar 0 0 0)
                (word-spec 'baz 'quux 1 0 0))))
  (check
   (call-with-port (open-string-input-port
                    (call-with-string-output-port
                      (lambda (p) (save-word-spec* ws p))))
     (lambda (p)
       (load-word-spec* p)))
   (=> equal?) ws))

(let* ((w 'foo)
       (m 'bar)
       (o 1)
       (n 0)
       (d 0)
       (spec (word-spec w m o n d)))
  (check (word-spec-word spec) => w)
  (check (word-spec-meaning spec) => m)
  (check (word-spec-ok spec) => o)
  (check (word-spec-ng spec) => n)
  (check (word-spec-date spec) => d)

  ;; word-spec-incr-ok changes word-spec-ok only
  (let ((s (word-spec-incr-ok spec)))
    (check (word-spec-ok s)
           => (+ (word-spec-ok spec) 1))
    (check (word-spec-word s)
           => (word-spec-word spec))
    (check (word-spec-meaning s)
           => (word-spec-meaning spec))
    (check (word-spec-ng s)
           => (word-spec-ng spec))
    (check (word-spec-date s)
           => (word-spec-date spec))
    )

  ;; word-spec-incr-ng changes word-spec-ng only
  (let ((s (word-spec-incr-ng spec)))
    (check (word-spec-ng s)
           => (+ (word-spec-ng spec) 1))
    (check (word-spec-word s)
           => (word-spec-word spec))
    (check (word-spec-meaning s)
           => (word-spec-meaning spec))
    (check (word-spec-ok s)
           => (word-spec-ok spec))
    (check (word-spec-date s)
           => (word-spec-date spec))
    )
  )

(let ((foo 3)(bar 5)(tmp 7))
  (swap! foo bar)
  (swap! foo tmp)
  (check foo => 7)
  (check bar => 3)
  (check tmp => 5))

(check-report)
(exit 0)

;; Local variables:
;; indent-tabs-mode: nil
;; End: