Hatena::Groupcadr

わだばLisperになる このページをアンテナに追加 RSSフィード

2004 | 12 |
2005 | 01 | 02 | 07 | 10 | 11 |
2006 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2007 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2008 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2009 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2010 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2011 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 11 |

2010-01-09

Shibuya.lisp に向けて Scheme コードバトンするのはどうか?

| 19:33 | Shibuya.lisp に向けて Scheme コードバトンするのはどうか? - わだばLisperになる を含むブックマーク はてなブックマーク - Shibuya.lisp に向けて Scheme コードバトンするのはどうか? - わだばLisperになる

higeponさんが、Shibuya.lisp に向けて Scheme コードバトンするのはどうか?とのことだったので、R6RS SchemeをCLに適当翻訳。

もとのコードに少し機能拡張を加えていながら、gotoや&auxを使っていたりして下品な風味に仕上げました。

やる気のある方は、是非、綺麗に書き直してみて下さい!

(defun read-dict (file)
  (with-open-file (in file)
    (read in)))

(defun write-dict (file data)
  (with-open-file (out file :direction :output :if-exists :supersede)
    (with-standard-io-syntax 
        (print data out))))

(defun sort-word-spec* (word-spec*)
  (sort (mapcar (lambda (x)
                  (destructuring-bind
                        (word meaning &optional (ok-count 0) (ng-count 0)) x
                    (list word meaning ok-count ng-count)))
                word-spec*)
        (lambda (a b)
          (destructuring-bind (word meaning ok-count1 ng-count1) a
            (declare (ignore word meaning))
            (destructuring-bind (word meaning ok-count2 ng-count2) b
              (declare (ignore word meaning))
              (> (- ng-count1 ok-count1)
                 (- ng-count2 ok-count2)))))))

(defun main (file &aux (ans (read-dict file)))
  (loop :named loop
        :for (word-spec . more) :on (sort-word-spec* ans)
        :for (word meaning ok-count ng-count) := word-spec
        :do (progn (format *query-io* "~A: " word)
                   (read-char *query-io*)     ;wait
                   (format *query-io* "~A y/n? " meaning))
        :collect (block ask
                   (tagbody 
                    :again
                      (return-from ask
                        (case (progn 
                                (clear-input *query-io*)
                                (prog1 (read-char *query-io*)
                                       (clear-input *query-io*)))
                          ((#\y #\Y) (list word meaning (1+ ok-count) ng-count))
                          ((#\n #\N) (list word meaning ok-count (1+ ng-count)))
                          ((#\q #\Q) (progn
                                       (setq ans (append result-spec*
                                                         (list word-spec)
                                                         more))
                                       (return-from loop)))
                          (T (progn
                               (format *query-io*
                                       "~&Please type Y for yes or N for no or Q for quit.~%")
                               (go :again)))))))
        :into result-spec*
        :finally (setq ans result-spec*))
  (when ans
    (write-dict file ans)))

実行例

CL-USER> (main "dict.lisp")
BAR: ↓:改行
ばー y/n? foo ↓

Please type Y for yes or N for no or Q for quit.
aaaaaa ↓
Please type Y for yes or N for no or Q for quit.
y<改行>
BAZ: ↓
ばず y/n? y ↓
FOO: <改行>
ふー y/n? y ↓

;=> ((BAR "ばー" 1 0) (BAZ "ばず" 1 0) (FOO "ふー" 2 0))

dict.lispの中身

((FOO "ふー" 0 0) (BAR "ばー" 0 0) (BAZ "ばず" 0 0))

ちなみに、ご覧の通り、シェルから実行というよりREPLであれこれというタイプです。