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)
;;  10. naoya_t (http://blog.livedoor.jp/naoya_t/): 改めてGaucheとmoshの共存を目指しました。

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

;; ■英単語暗記補助ツールです
;;   起動すると辞書ファイルから単語が表示されるので意味を頭で考えます。何かキーを押すと答えが表示されます。 (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

;;
;; Gaucheでもmoshでも走るプログラムを目指しています。
;; cond-expand を利用して処理系毎の処理を記述していますが、
;; moshでは (import (srfi :0)) しないと cond-expand が使えないので
;; Gaucheの場合は最初の(import (rnrs) ...)をコメントアウトして使います。
;; moshの場合は #; を外してください。[naoya_t]
;;
#;(import (rnrs)
        (mosh ffi)
        (match)
        (only (srfi :1 lists)
              append-reverse iota
              unfold alist-cons first second third fourth fifth)
        (srfi :0)
        (srfi :19)
        (srfi :37 args-fold)
        (srfi :39 parameters)
        (srfi :48 intermediate-format-strings)
        (srfi :78 lightweight-testing)
        )

(cond-expand
 (mosh
  (define *interpreter-name* "mosh")
  ;;端末制御
  (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 *window-ptr* #f)
  (define (curses-format fmt . args) (addstr (string->pointer (apply format fmt args))))
  
  (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*))

  ;; 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)))))
  )

 (gauche
  (define *interpreter-name* "Gauche")
  (use srfi-1)
  (use srfi-19)
  (use srfi-37)
  (use gauche.test)
  (use gauche.parseopt)
  (use gauche.charconv)
  (use gauche.uvector)
  (use util.match)
  (use c-wrapper)

  ;; SRFI-39
  (define (make-parameter init . conv)
    (let ((converter (if (null? conv) (lambda (x) x) (car conv))))
      (let ((global-cell (cons #f (converter init))))
        (letrec ((parameter (lambda new-val
                              (let ((cell (dynamic-lookup parameter global-cell)))
                                (cond ((null? new-val) (cdr cell))
                                      ((null? (cdr new-val)) (set-cdr! cell (converter (car new-val))))
                                      (else (converter (car new-val)))))))) ; this case is needed for parameterize
          (set-car! global-cell parameter)
            parameter))))
  (define-syntax parameterize
    (syntax-rules ()
      ((parameterize ((expr1 expr2) ...) body ...)
       (dynamic-bind (list expr1 ...)
                     (list expr2 ...)
                     (lambda () body ...)))))
  (define (dynamic-bind parameters values body)
    (let* ((old-local (dynamic-env-local-get))
           (new-cells (map (lambda (parameter value) (cons parameter (parameter value #f)))
                           parameters
                           values))
           (new-local (append new-cells old-local)))
      (dynamic-wind
          (lambda () (dynamic-env-local-set! new-local))
          body
          (lambda () (dynamic-env-local-set! old-local)))))
  (define (dynamic-lookup parameter global-cell)
    (or (assq parameter (dynamic-env-local-get))
        global-cell))
  (define dynamic-env-local '())
  (define (dynamic-env-local-get) dynamic-env-local)
  (define (dynamic-env-local-set! new-env) (set! dynamic-env-local new-env))

  ;; c-wrapperでncurseswを呼び出します。ライブラリのパスは環境によりますね[naoya_t]
  (c-load-library "/opt/local/lib/libncursesw.dylib")
  (c-include "curses.h") ;; initscr cbreak noecho getch endwin move addstr waddnstr timeout)
  (define (curses-format fmt . args)
    (let1 formatted-message (apply format fmt args)
      (guard (e (else (format #t "ERROR: ~a\n" (slot-ref e 'message)))) ;; 参考のためにあえて残しときますよ[naoya_t]
        ;; (addstr formatted-message) ;; マクロ展開でc-wrapperにエラー言われるので没[naoya_t]
        (waddnstr *window-ptr* formatted-message (string-size formatted-message))
        )))

  (c-load "stdlib.h" :import 'malloc)
  (c-load "locale.h" :import 'setlocale)

  (define (string->pointer str) str)
  (define (list-sort proc list) (sort list proc))

  (define-syntax check
    (syntax-rules (=>)
      ((_ expr => expected)
       (test* (format "~a" expr) expected expr))
      ((_ expr (=> proc) expected)
       (test* (format "~a" expr) expected expr proc))))
  (define check-report test-end)
  (define open-string-input-port open-input-string)
  (define-macro (call-with-port port thunk) `(,thunk ,port))
  (define call-with-string-output-port call-with-output-string)

  (define *window-ptr* #f)
  (define (timeout delay) (wtimeout *window-ptr* delay))

  (define-macro (try-finally body cleanup)
    `(guard (e (else ,cleanup))
       (begin0
         ,body
         ,cleanup)))
  ));; cond-expand

(define LC_ALL 0)                       ; !!環境依存!! MacOSXでは0でした.[naoya_t]

(define *gist-url* "http://gist.github.com/279595")
(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    first)
(define word-spec-meaning second)
(define word-spec-ok      third)
(define word-spec-ng      fourth)
(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-macro ($$ name) `(%getopt ,name))
(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-syntax with-curses
  (syntax-rules ()
    [(_ body)
     (begin
       ;; 端末を設定
       (setlocale LC_ALL (string->pointer "ja_JP.utf-8"))
       (set! *window-ptr* (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)
           (curses-format "~s: " (question spec))
           ;; 何かキーが押されるのを待つ
           (when (eq? (getch-with-timeout
                       (* (string->number ($$ timeout)) 1000))
                      -1)
                 (curses-format "Timeout!: ~s" (answer spec))
                 (loop (cdr word-spec*)
                       (cons (word-spec-incr-ng spec) result-spec*)
                       (+ y-index 1)))
           ;; 答え表示
           (curses-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
              ;;(if (null? word-spec*) result-spec*
              (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))
  (cond-expand
   (gauche
    (call-with-output-file dict-file
      (lambda (oport)
        (save-word-spec* specs oport))
      :if-does-not-exist :create
      :if-exists :overwrite
      :buffering :full
      :element-type :character))
   (mosh
    (call-with-port
     (open-file-output-port dict-file
                            (file-options no-fail)
                            (buffer-mode block)
                            (native-transcoder))
     (lambda (oport)
       (save-word-spec* specs oport))))
   ))

(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 ($$ verbose)
    (format #t "This script is running on ~a." *interpreter-name*) (newline))
  (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))


(cond-expand
 (gauche
  (let-args *argv*
      ((debug "d|debug" #f)
       (verbose "v|verbose" #f)
       (dict-file "f|dict-file=s" "words.txt")
       (reverse "r|reverse" #f)
       (timeout "t|timeout=s" "10")
       (help "h|help" #f)
       (test "T|test" #f))
    (let ((alis `((debug . ,debug)
                  (verbose . ,verbose)
                  (dict-file . ,dict-file)
                  (reverse . ,reverse)
                  (timeout . ,timeout)
                  (help . ,help)
                  (test . ,test))))
      (set! *command-line-options* (lambda () alis))
      (unless ($$ test)
        (main *argv*)))))
 (mosh
  (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))))

(cond-expand
 (gauche
  (test-start "scheme-baton")
  (test-section "testing with gauche.test"))
 (mosh
  #f))

(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) ;; これがないと特にGaucheでは (main) が自動的に呼び出されてしまいます
;; Local variables:
;; indent-tabs-mode: nil
;; End: