scheme_button.lsp

#!/usr/bin/newlisp

;; 第1回 Scheme コードバトン (newLISP fork)
;;
;; ■ これは何か？
;;   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. kosh (http://lisperblog.blogspot.com): とりあえずnewLISPでも動作するように。

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

;; ■英単語暗記補助ツールです
;;   起動すると辞書ファイルから単語が表示されるので意味を頭で考えます。
;;;  Ctrl-D を押すと答えが表示されます。 (y/n) を聞かれるので正解なら y を押してください。
;;   間違った単語は辞書ファイルに記録され次回出題されます。
;;
;; ■動作方法
;;   newlisp v.10.1.7 で動作確認しています
;;   % newlisp scheme_button.lsp FILE|URL
;;
;; ■辞書ファイルの例
;;   http://gist.github.com/273424.txt


;; 辞書エントリの書式
;;  0    1       2        3
;; (word meaning ok-count ng-count)

;; syntax: (aif test then [else])
(define-macro (aif)
  (let (it (eval (args 0)))
    (if it
        (eval (args 1))
        (eval (cons 'begin (2 (args)))))))

(define (normalize-entry e)
  (cond
    ;; (word meaning) -> (word meaning 0 0)
    ((match '(? ?) e) (append e '(0 0)))
    ;; (word meaning ok-count ng-count)
    ((match '(? ? ? ?) e) e)
    ;; otherwise
    (true (throw-error (list "wrong entry" e)))
    ))

(define-macro (add-entry)
  (push (normalize-entry (eval (args 0))) (eval (args 1)) -1))

;; ファイルを読んで S 式のリストにする
(define (load-dict file)
  (let ((buffer (read-file file))
        (spec* '()))
    (unless buffer
      (throw-error (list (sys-error) file)))
    (until (empty? buffer)
      (aif (read-expr buffer)
           (add-entry it spec*))
      (setq buffer (slice buffer $0)))
    spec*))

(define (save-dict file spec* (verbose true))
  (when verbose (print ";; saving dict..."))
  (let (buffer "")
    (dolist (spec spec*)
      (write-line buffer (string spec)))
    (write-file file buffer))
  (when verbose (println "done"))
  true)

(define (ng-count> x y)
  (> (- (x 3) (x 2))
     (- (y 3) (y 2))))

(define (main dict-file)
  (let ((word-spec*
         ;; 間違いが多い順にソート
         (sort (load-dict dict-file) ng-count>)))
    (catch
        (dolist (spec word-spec*)
          ;; 問題出題
          (print (spec 0) ": ")
          ;; 入力待ち (or Ctrl-D)
          (read-line)
          ;; 答え表示
          (print (spec 1) " [y/n/q]? ")
          (case ((or (read-line) "q") 0)
            ("y" (inc (word-spec* (list $idx 2))))
            ("n" (inc (word-spec* (list $idx 3))))
            ("q" (throw)))))
    (if (starts-with dict-file "https?://" 0)
        (setq dict-file "./words.txt"))
    ;; 正答と誤答を記録
    (save-dict dict-file word-spec*))
  (exit))

(main (main-args 2))