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-31

KMRCLを眺める (77) WRITE-UTIME-HMS

| 13:50 | KMRCLを眺める (77) WRITE-UTIME-HMS - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (77) WRITE-UTIME-HMS - わだばLisperになる

今回はKMRCLのio.lisp中からWRITE-UTIME-HMSです。

前回のWRITE-UTIME-HMS-STREAMをラップしたもので、定義は、

(defun write-utime-hms (utime &key utc-offset stream)
  (if stream
      (write-utime-hms-stream utime stream utc-offset)
    (with-output-to-string (s)
      (write-utime-hms-stream utime s utc-offset))))

となっています。

WRITEという名前からすると、stream指定の省略のデフォルトが、文字列ストリームというのがいまいちシステム標準と整合性がない気がして個人的な趣味に合いませんが、FORMAT的に

(WRITE-UTIME-HMS (GET-UNIVERSAL-TIME) :STREAM NIL)

の省略と考えれば良いようなそうでもないような。

動作は、

(WRITE-UTIME-HMS (GET-UNIVERSAL-TIME))
;⇒ "13:50:52"

です。

2010-01-29

KMRCLを眺める (76) WRITE-UTIME-HMS-STREAM

| 08:19 | KMRCLを眺める (76) WRITE-UTIME-HMS-STREAM - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (76) WRITE-UTIME-HMS-STREAM - わだばLisperになる

今回はKMRCLのio.lisp中からWRITE-UTIME-HMS-STREAMです。

定義を眺めてみると

(defun write-utime-hms-stream (utime stream &optional utc-offset)
  (with-utime-decoding-utc-offset (utime utc-offset)
    (write-string (aref +datetime-number-strings+ hour) stream)
    (write-char #\: stream)
    (write-string (aref +datetime-number-strings+ minute) stream)
    (write-char #\: stream)
    (write-string (aref +datetime-number-strings+ second) stream)))

となっています。

この中の+DATETIME-NUMBER-STRINGS+ですが、

(defvar +datetime-number-strings+
  (make-array 61 :adjustable nil :element-type 'string :fill-pointer nil
              :initial-contents
              '("00" "01" "02" "03" "04" "05" "06" "07" "08" "09" "10" "11"
                "12" "13" "14" "15" "16" "17" "18" "19" "20" "21" "22" "23"
                "24" "25" "26" "27" "28" "29" "30" "31" "32" "33" "34" "35"
                "36" "37" "38" "39" "40" "41" "42" "43" "44" "45" "46" "47"
                "48" "49" "50" "51" "52" "53" "54" "55" "56" "57" "58" "59"
                "60")))

となっています。

なんでこんなものを定義するのかなと最初は思いましたが、WRITE-UTIME-HMS-STREAMの実装を眺めるに、必要な都度、数字→文字の変換をするのは効率が悪い、ということなのでしょうか。

動作は、

(WITH-OUTPUT-TO-STRING (OUT)
  (WRITE-UTIME-HMS-STREAM (GET-UNIVERSAL-TIME) OUT))
;⇒ "8:30:10"

というところです。

2010-01-28

KMRCLを眺める (75) WITH-UTIME-DECODING-UTC-OFFSET

| 23:46 | KMRCLを眺める (75) WITH-UTIME-DECODING-UTC-OFFSET - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (75) WITH-UTIME-DECODING-UTC-OFFSET - わだばLisperになる

今回はKMRCLのio.lisp中からWITH-UTIME-DECODING-UTC-OFFSETです。

WITH-UTIME-DECODINGにUTCからのオフセットを指定できるもののようです。

定義を眺めてみると

(defmacro with-utime-decoding-utc-offset ((utime utc-offset) &body body)
  (with-gensyms (zone)
    `(let* ((,zone (cond
                    ((eq :utc ,utc-offset)
                     0)
                    ((null ,utc-offset)
                     nil)
                    (t
                     (if (is-dst ,utime)
                         (1- (- ,utc-offset))
                       (- ,utc-offset))))))
       (if ,zone
           (with-utime-decoding (,utime ,zone)
             ,@body)
         (with-utime-decoding (,utime)
           ,@body)))))

というもの。

動作例は、

(WITH-UTIME-DECODING-UTC-OFFSET ((GET-UNIVERSAL-TIME) NIL)
  (LIST YEAR MONTH DAY-OF-MONTH HOUR MINUTE))
⇒ (2010 1 28 23 45)

(WITH-UTIME-DECODING-UTC-OFFSET ((GET-UNIVERSAL-TIME) 0)
  (LIST YEAR MONTH DAY-OF-MONTH HOUR MINUTE))
⇒ (2010 1 28 14 45)

(WITH-UTIME-DECODING-UTC-OFFSET ((GET-UNIVERSAL-TIME) :UTC)
  (LIST YEAR MONTH DAY-OF-MONTH HOUR MINUTE))
⇒ (2010 1 28 14 46)

(WITH-UTIME-DECODING-UTC-OFFSET ((GET-UNIVERSAL-TIME) 9)
 (LIST YEAR MONTH DAY-OF-MONTH HOUR MINUTE))
⇒ (2010 1 28 23 48)

世界時計を作るのに便利そうです。

2010-01-27

KMRCLを眺める (74) IS-DST

| 23:19 | KMRCLを眺める (74) IS-DST - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (74) IS-DST - わだばLisperになる

今回はKMRCLのio.lisp中からIS-DSTです。

DSTってなんだと思って調べてみるとdaylight saving timeということで夏時間のことなんですね。

日本に住んでるとあまり馴染がないですが、CLのUNIVERSAL-TIMEでも夏時間を扱うことができます。

ということで、定義を眺めてみると

(defun is-dst (utime)
  (with-utime-decoding (utime)
    daylight-p))

という風に以前に定義したWITH-UTIME-DECODINGを利用してDAYLIGHT-Pのところを抜き出しています。

動作例は、

(IS-DST (GET-UNIVERSAL-TIME))
;⇒ NIL ;もしくはT

2010-01-26

KMRCLを眺める (73) WITH-UTIME-DECODING

| 23:27 | KMRCLを眺める (73) WITH-UTIME-DECODING - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (73) WITH-UTIME-DECODING - わだばLisperになる

今回はKMRCLのio.lisp中からWITH-UTIME-DECODINGです。

定義を眺めてみると

(defmacro with-utime-decoding ((utime &optional zone) &body body)
  "UTIME is a universal-time, ZONE is a number of hours offset from UTC, or NIL to use local time.  Execute BODY in an environment where SECOND MINUTE HOUR DAY-OF-MONTH MONTH YEAR DAY-OF-WEEK DAYLIGHT-P ZONE are bound to the decoded components of the universal time"
  `(multiple-value-bind
       (second minute hour day-of-month month year day-of-week daylight-p zone)
       (decode-universal-time ,utime ,@(if zone (list zone)))
     (declare (ignorable second minute hour day-of-month month year day-of-week daylight-p zone))
     ,@body))

となっていますが、アナフォリックマクロの一種みたいですね。

動作は、

(WITH-UTIME-DECODING ((GET-UNIVERSAL-TIME))
  (LIST YEAR MONTH DAY-OF-MONTH))
;⇒ (2010 1 26)

という風になっています。

YEARや、MONTHの変数に暗黙の変数束縛があるわけですね。

UTIME系の構文は毎度のようにSECONDや、HOUR等をずらっと並べて書くのが面倒なことがあるので、これは結構便利かもしれなと思いました。

2010-01-25

KMRCLを眺める (72) NULL-OUTPUT-STREAM

| 01:10 | KMRCLを眺める (72) NULL-OUTPUT-STREAM - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (72) NULL-OUTPUT-STREAM - わだばLisperになる

今回はKMRCLのio.lisp中からNULL-OUTPUT-STREAMです。

前回、

(LET ((NULL-STREAM (MAKE-INSTANCE 'SB-SIMPLE-STREAMS:NULL-SIMPLE-STREAM)))
  (LOOP :REPEAT 1000000
        :DO (WRITE-FIXNUM (RANDOM MOST-POSITIVE-FIXNUM)
                          NULL-STREAM)))

のようなテストで、出力を捨てるために、NULL-STREAMを作成していましたが、今回のNULL-OUTPUT-STREAMはそのNULL-STREAMを作成するものです。

定義は、

(defun null-output-stream ()
  (when (probe-file #p"/dev/null")
    (open #p"/dev/null" :direction :output :if-exists :overwrite)))

となっていて、UNIXの/dev/nullを利用しています。

NULLストリームの作成方法については、逆引きCommon Lispにもあるのですが、

逆引きCL:NULLストリームを使う

(MAKE-TWO-WAY-STREAM (MAKE-CONCATENATED-STREAM) 
                     (MAKE-BROADCAST-STREAM))

というコードで 読み出すとEOF & 書き込みは捨てられる ストリームが作成できます。

また、処理系にも非依存です。

/dev/nullを利用する方法がわざわざ使われているからには、そっちの方が性能が良かったりするのかもしれない、ということで速度を測定してみました。

  • NULL-OUTPUT-STREAM
Test with 10 iterations: ((LET ((NULL-STREAM (NULL-OUTPUT-STREAM)))
                            (LOOP :REPEAT 1000000
                                  :DO (WRITE-FIXNUM
                                       (RANDOM MOST-POSITIVE-FIXNUM)
                                       NULL-STREAM))))
Total time: 28.73 sec, time per iteration: 2.87 sec
  • (MAKE-TWO-WAY-STREAM (MAKE-CONCATENATED-STREAM) (MAKE-BROADCAST-STREAM))
Test with 10 iterations: ((LET ((NULL-STREAM
                                 (MAKE-TWO-WAY-STREAM
                                  (MAKE-CONCATENATED-STREAM)
                                  (MAKE-BROADCAST-STREAM))))
                            (LOOP :REPEAT 1000000
                                  :DO (WRITE-FIXNUM
                                       (RANDOM MOST-POSITIVE-FIXNUM)
                                       NULL-STREAM))))
Total time: 24.60 sec, time per iteration: 2.46 sec

大体同じか、/dev/nullを利用しない方がちょっと速いようです。

これだったら(MAKE-TWO-WAY-STREAM (MAKE-CONCATENATED-STREAM) (MAKE-BROADCAST-STREAM))の方を使っておいた方が良い気がします。

2010-01-24

KMRCLを眺める (71) WRITE-FIXNUM

| 02:43 | KMRCLを眺める (71) WRITE-FIXNUM - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (71) WRITE-FIXNUM - わだばLisperになる

今回はKMRCLのio.lisp中からWRITE-FIXNUMです。

動作は、その名の通り

(WITH-OUTPUT-TO-STRING (OUT)
  (WRITE-FIXNUM 8 OUT))
⇒ "8"

となっています。

定義は、

(declaim (inline write-fixnum))
(defun write-fixnum (n s)
  #+allegro (excl::print-fixnum s 10 n)
  #-allegro (write-string (write-to-string n) s))

となっていますが、Allegro CLだとFIXNUM専用の関数があって速くなるような様子ぶり。

本当なんだろうかということで実験してみました。

;; 百万回FIXNUMを出力
(LET ((NULL-STREAM (MAKE-INSTANCE 'STREAM::NULL-STREAM)))
  (LOOP :REPEAT 1000000 
        :DO (WRITE-FIXNUM (RANDOM MOST-POSITIVE-FIXNUM)
                          NULL-STREAM)))
;⇒ NIL
----------
; cpu time (non-gc) 5,350 msec user, 20 msec system
; cpu time (gc)     1,340 msec user, 150 msec system
; cpu time (total)  6,690 msec user, 170 msec system
; real time  6,974 msec
; space allocation:
;  17,002,102 cons cells, 29,232 other bytes, 18,128 static bytes
(declaim (inline write-fixnum-slow))
(defun write-fixnum-slow (n s)
  (write-string (write-to-string n) s))
;; 百万回FIXNUMを出力
(LET ((NULL-STREAM (MAKE-INSTANCE 'STREAM::NULL-STREAM)))
  (LOOP :REPEAT 1000000
        :DO (WRITE-FIXNUM-SLOW (RANDOM MOST-POSITIVE-FIXNUM)
                               NULL-STREAM)))
;⇒ NIL
----------
; cpu time (non-gc) 12,380 msec user, 50 msec system
; cpu time (gc)     230 msec user, 0 msec system
; cpu time (total)  12,610 msec user, 50 msec system
; real time  12,673 msec
; space allocation:
;  20,000,245 cons cells, 79,996,576 other bytes, 54,864 static bytes

確かに手元では、倍くらい速いようです。

しかし、こんなに大量にFIXNUMを高速にWRITEしたいことってあるんだろうか…。

2010-01-22

KMRCLを眺める (70) PRINT-ROWS

| 01:11 | KMRCLを眺める (70) PRINT-ROWS - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (70) PRINT-ROWS - わだばLisperになる

今回はKMRCLのio.lisp中からPRINT-ROWSです。

動作は、

(WITH-OUTPUT-TO-STRING (OUT)
  (PRINT-ROWS '((A     B 
                 C
                 D
                 E)
                (1
                 2 3 4 5)
                (1 2 3 4 5))
              OUT))

⇒ "A B C D E
1 2 3 4 5
1 2 3 4 5
"

となっていて、リストのリストの内容を綺麗に表示するもののようです。

定義は、

(defun print-rows (rows &optional (ostrm *standard-output*))
  "Print a list of list rows to a stream"
  (dolist (r rows) (format ostrm "~{~A~^ ~}~%" r)))

です。そのままです。

(format t
        "~{~{~A~^ ~}~%~}" 
        '((A     B 
           C
           D
           E)
          (1
           2 3 4 5)
          (1 2 3 4 5)))

と書いて解決、という人も多い気がします…。

2010-01-21

ABCLをソースからビルドするためのメモ ant編

| 01:36 | ABCLをソースからビルドするためのメモ ant編 - わだばLisperになる を含むブックマーク はてなブックマーク - ABCLをソースからビルドするためのメモ ant編 - わだばLisperになる

ちょっと前のことになりますが、なにかのきっかけでABCLがちょっと盛り上がり、このブログにABCLのビルド方法で検索して辿り着いている方が増えていたようでした。

それらのエントリーは、

なのですが、これを書いた当時、自分はJavaのantを全く知らなかったため、SBCL等でビルドするという方法を書いておりました。

しかし、antだと

$ tar xvf /usr/local/abcl/abcl-src-0.18.1.tar.gz
$ cd abcl-src-0.18.1
$ ant abcl
$ ./abcl
Armed Bear Common Lisp 0.18.1
Java 1.6.0_16 Sun Microsystems Inc.
Java HotSpot(TM) 64-Bit Server VM
Low-level initialization completed in 0.339 seconds.
Startup completed in 0.992 seconds.
Type ":help" for a list of available commands.
CL-USER(1):

これだけの手順で、abclが生成されるのです…。

SBCLを使ってのビルドがややこしくて、ABCLのビルドに挫折していた方がいたとしたら、ごめんなさい…。

KMRCLを眺める (69) PRINT-LIST

| 01:22 | KMRCLを眺める (69) PRINT-LIST - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (69) PRINT-LIST - わだばLisperになる

今回はKMRCLのio.lisp中からPRINT-LISTです。

動作は、

(WITH-OUTPUT-TO-STRING (OUT)
  (PRINT-LIST '(1 2 3 4) OUT))
⇒ "1
2
3
4
"

となっていて、リストの内容を一つずつPRINTするというものです。

定義は、

(defun print-list (l &optional (output *standard-output*))
  "Print a list to a stream"
  (format output "~{~A~%~}" l))

PRINT-LISTと名前が付いてた方が便利な気もしますが、そのまま(format output "~{~A~%~}" '(1 2 3 4))と書く人が多い気がしないでもないです。

2010-01-20

KMRCLを眺める (68) INDENT-HTML-SPACES

| 01:06 | KMRCLを眺める (68) INDENT-HTML-SPACES - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (68) INDENT-HTML-SPACES - わだばLisperになる

今回はKMRCLのio.lisp中からINDENT-HTML-SPACESです。

前回は、空白文字でしたが、HTMLの文字実体参照の空白を出力するものです。

HTMLを出力するプログラムで使いたくなったりするんでしょうか。

動作は、

(WITH-OUTPUT-TO-STRING (OUT)
  (INDENT-HTML-SPACES 3 OUT))
;⇒ "      "

という感じ。

定義は、

(defun indent-html-spaces (n &optional (stream *standard-output*))
  "Indent n*2 html spaces to output stream"
  (print-n-strings " " (+ n n) stream))

これもなぜか指定の数の2倍ずつ出力。

2010-01-19

KMRCLを眺める (67) INDENT-SPACES

| 01:46 | KMRCLを眺める (67) INDENT-SPACES - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (67) INDENT-SPACES - わだばLisperになる

今回はKMRCLのio.lisp中からINDENT-SPACESです。

動作は、名前の通りインデント用(多分)のスペースを出力します。

(WITH-OUTPUT-TO-STRING (OUT)
  (INDENT-SPACES 3 OUT))
;⇒ "      "

定義は、

(defun indent-spaces (n &optional (stream *standard-output*))
  "Indent n*2 spaces to output stream"
  (print-n-chars #\space (+ n n) stream))

という風に以前に定義したPRINT-N-CHARSを利用しています。

しかし、なぜに指定した数の二倍出力されるんでしょう。

2010-01-18

Xで良い

| 00:22 | Xで良い - わだばLisperになる を含むブックマーク はてなブックマーク - Xで良い - わだばLisperになる

LISPを普段から読んだり書いたりしてる方は、LAMBDAを書くことも多いと思います。

自分が好きで読んでいるソースは比較的古いMacLISPや、Lispマシンのものが多いのですが、今も昔もLAMBDAの引数の変数名については非常に適当な付け方をしているように感じます。

その中でも実感としては、圧倒的にXが多い筈と思っていたのですが、ふとGoogle Code Searchで調べてみる気になって調べてみました。

APIを使って色々調べると面白そうなのですが、使い方が良く分からないので、とりあえず一文字変数を地道に調べて多い順に並べてみました。

http://img.f.hatena.ne.jp/images/fotolife/g/g000001/20100118/20100118001827.png

((X . 13900)
 (C . 3000)
 (A . 2000)
 (S . 2000)
 (E . 1000)
 (K . 1000)
 (N . 1000)
 (P . 1000)
 (V . 1000)
 (Y . 1000)
 (F . 847)
 (L . 772)
 (I . 723)
 (M . 647)
 (R . 545)
 (U . 498)
 (B . 490)
 (Z . 455)
 (D . 388)
 (W . 370)
 (Q . 242)
 (G . 209)
 (O . 190)
 (J . 140)
 (H . 104)
 (T . 7))

やはり圧倒的にXなようです。

もう何も考えずXを使っていることが多いんじゃないかとさえ思います。

Cが多いというのが意外だったのですが、処理系のソースでcharを処理するのが多いからかもしれません。

Aも何も考えてない系の選択ですね。

ちなみに、本来Tは0件な気もするんですが、7件あるというのが面白いです。

2010-01-17

KMRCLを眺める (66) PRINT-N-STRINGS

| 00:58 | KMRCLを眺める (66) PRINT-N-STRINGS - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (66) PRINT-N-STRINGS - わだばLisperになる

今回はKMRCLのio.lisp中からPRINT-N-STRINGSです。

前回のPRINT-N-CHARSに続いて今度は文字列版

動作は、こんな感じです。

(WITH-OUTPUT-TO-STRING (OUT)
  (PRINT-N-STRINGS "ラドレ" 10 OUT))
;⇒ "ラドレラドレラドレラドレラドレラドレラドレラドレラドレラドレ"

定義は、

(defun print-n-strings (str n stream)
  (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0)))
  (dotimes (i n)
    (declare (fixnum i))
    (write-string str stream)))

という風になっています。

前回謎だった重複したdeclareの宣言ですが、HyperSpecを眺めてもどこに書いているかみつけられませんでした…。

とりあえず、手元のSBCLで試すと、

(LET ((X (1+ MOST-POSITIVE-FIXNUM)))
  (DECLARE (NUMBER X))
  (DECLARE (FIXNUM X))
  X)
>>> エラー

という風にエラーになるので、どうも同一の変数への宣言を並べて書くとANDな関係になるみたいです。

(LET ((X (1+ MOST-POSITIVE-FIXNUM)))
  (DECLARE (TYPE (AND NUMBER FIXNUM) X))
  X)
>>> エラー

という風に書いたのと同じなのかもしれません。

HyperSpecでの記述をご存知の方は是非教えて下さい!

2010-01-15

KMRCLを眺める (65) PRINT-N-CHARS

| 23:44 | KMRCLを眺める (65) PRINT-N-CHARS - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (65) PRINT-N-CHARS - わだばLisperになる

今回はKMRCLのio.lisp中からPRINT-N-CHARSです。

名前のとおりN回文字を出力するというもので動作は、

(WITH-OUTPUT-TO-STRING (OUT)
  (PRINT-N-CHARS #\A 15 OUT))
;⇒ "AAAAAAAAAAAAAAA"

こんな感じです。

定義は、

(defun print-n-chars (char n stream)
  (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0)))
  (dotimes (i n)
    (declare (fixnum i))
    (write-char char stream)))

という風になっています。

DOTIMESで利用する変数に型宣言が付いていますが、DOTIMESは処理系側でマクロの中に宣言を入れているものが多いようで、上記のマクロを展開するとSBCL等の場合

(DO ((I 0 (1+ I))
     (#:COUNT2837 N))
    ((>= I #:COUNT2837) NIL)
    (DECLARE (TYPE UNSIGNED-BYTE I)
             (TYPE INTEGER #:COUNT2837))
    (DECLARE (FIXNUM I))
    (WRITE-CHAR CHAR STREAM))

という風になります。

こういう場合ってどっちの宣言が優先されるんでしょうね。

さて、HyperSpecで調べてみよう…。

2010-01-14

KMRCLを眺める (64) FILE-SUBST

| 01:44 | KMRCLを眺める (64) FILE-SUBST - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (64) FILE-SUBST - わだばLisperになる

今回はKMRCLのio.lisp中からFILE-SUBSTです。

前回のSTREAM-SUBSTを包んだものになっていて、定義は、

(defun file-subst (old new file1 file2)
  (with-open-file (in file1 :direction :input)
    (with-open-file (out file2 :direction :output
                         :if-exists :supersede)
      (stream-subst old new in out))))

という風になっています。

動作は、

(FILE-SUBST "Ubuntu" "__Ubuntu__" "/etc/motd" "/tmp/motd"))

などとすると、/etc/motdの中身を書き換えたものを/tmp/motdにファイルとして出力します

/etc/motd

Linux setq 2.6.31-14-generic #48-Ubuntu SMP Fri Oct 16 14:05:01 UTC 2009 x86_64

To access official Ubuntu documentation, please visit:
http://help.ubuntu.com/

/tmp/motd

Linux setq 2.6.31-14-generic #48-__Ubuntu__ SMP Fri Oct 16 14:05:01 UTC 2009 x86_64

To access official __Ubuntu__ documentation, please visit:
http://help.ubuntu.com/

sedのように高機能ではないですが、そこそこ使えることもあるのかもしれません

2010-01-12

KMRCLを眺める (63) STREAM-SUBST

| 23:17 | KMRCLを眺める (63) STREAM-SUBST - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (63) STREAM-SUBST - わだばLisperになる

今回はKMRCLのio.lisp中からSTREAM-SUBSTです。

順番どおりだと、STREAM-SUBSTはもう少し後になるのですが、以降は、中でSTREAM-SUBSTを使っているのがあるので、先に読むことにしました。

まず、バッファを構造体で定義し、操作する関数群を定義しています。

;; Buffered stream substitute

(defstruct buf
  vec (start -1) (used -1) (new -1) (end -1))

(defun bref (buf n)
  (svref (buf-vec buf)
         (mod n (length (buf-vec buf)))))

(defun (setf bref) (val buf n)
  (setf (svref (buf-vec buf)
               (mod n (length (buf-vec buf))))
        val))

(defun new-buf (len)
  (make-buf :vec (make-array len)))

(defun buf-insert (x b)
  (setf (bref b (incf (buf-end b))) x))

(defun buf-pop (b)
  (prog1
    (bref b (incf (buf-start b)))
    (setf (buf-used b) (buf-start b)
          (buf-new  b) (buf-end   b))))

(defun buf-next (b)
  (when (< (buf-used b) (buf-new b))
    (bref b (incf (buf-used b)))))

(defun buf-reset (b)
  (setf (buf-used b) (buf-start b)
        (buf-new  b) (buf-end   b)))

(defun buf-clear (b)
  (setf (buf-start b) -1 (buf-used  b) -1
        (buf-new   b) -1 (buf-end   b) -1))

(defun buf-flush (b str)
  (do ((i (1+ (buf-used b)) (1+ i)))
      ((> i (buf-end b)))
    (princ (bref b i) str)))

こんな感じです。

自分的には、いまいち動作と関数名の印象が微妙に一致しないので読み辛い気がしました。

このbrefを利用して、stream-substを定義しています。

名前からすると、streamをsubstするという印象ですが、その通りで、ストリーム中の"old"文字列を"new"文字列に置換します。

(defun stream-subst (old new in out)
  (declare (string old new))
  (let* ((pos 0)
         (len (length old))
         (buf (new-buf len))
         (from-buf nil))
    (declare (fixnum pos len))
    (do ((c (read-char in nil :eof)
            (or (setf from-buf (buf-next buf))
                (read-char in nil :eof))))
        ((eql c :eof))
      (declare (character c))
      (cond ((char= c (char old pos))
             (incf pos)
             (cond ((= pos len)            ; 3
                    (princ new out)
                    (setf pos 0)
                    (buf-clear buf))
                   ((not from-buf)         ; 2
                    (buf-insert c buf))))
            ((zerop pos)                   ; 1
             (princ c out)
             (when from-buf
               (buf-pop buf)
               (buf-reset buf)))
            (t                             ; 4
             (unless from-buf
               (buf-insert c buf))
             (princ (buf-pop buf) out)
             (buf-reset buf)
             (setf pos 0))))
    (buf-flush buf out)))

なんとなく動作が追い掛けにくいのですが、

(DEFVAR *FOO* "こんにちは")

(WITH-OUTPUT-TO-STRING (OUT)
  (WITH-INPUT-FROM-STRING (IN *FOO*)
    (STREAM-SUBST "にち" "ばん" IN OUT)))
;⇒ こんばんは

という風に動きます。簡易版のsedというところ。

ところで、この関数をコンパイルして実行すると、SBCL等だと、

The value :EOF is not of type CHARACTER.

と怒られます。

DOの中で、変数Cを

(declare (character c))

と文字として宣言しているからなのですが、終端で:EOFというシンボルを返しているので:EOFが来た時にエラーとなるわけですね。

ということで、変数をcharacterとして宣言できて、かつ上手くいく方法はないかと考えたのですが、READ-CHARのEND-OF-FILEシグナルを拾うのはどうだろうと思いました。

(他の方法としては、:EOFとcharacterを合体させた新しい型を作るとか?)

(defun stream-subst (old new in out)
  (declare (string old new))
  (let* ((pos 0)
         (len (length old))
         (buf (new-buf len))
         (from-buf nil))
    (declare (fixnum pos len))
    (handler-case 
        (do ((c (read-char in)
                (or (setf from-buf (buf-next buf))
                    (read-char in))))
            (nil)
          (declare (character c))
          (cond ((char= c (char old pos))
                 (incf pos)
                 (cond ((= pos len)            ; 3
                        (princ new out)
                        (setf pos 0)
                        (buf-clear buf))
                       ((not from-buf)         ; 2
                        (buf-insert c buf))))
                ((zerop pos)                   ; 1
                 (princ c out)
                 (when from-buf
                   (buf-pop buf)
                   (buf-reset buf)))
                (t                             ; 4
                 (unless from-buf
                   (buf-insert c buf))
                 (princ (buf-pop buf) out)
                 (buf-reset buf)
                 (setf pos 0))))
      (end-of-file ()
        (buf-flush buf out)))))

自分はこれまで、READ系の関数は、デフォルトではシグナルを上げるようになっているのに、毎回わざわざNILと指定してやることに、なんとなく納得が行かなかったのですが、HANDLER-CASEで拾うようにすると、なんとなく気分が良い!

とはいえ、HANDLER-CASEの外で値を集積する書き方しかできないのが、使い勝手が微妙なところ。

(WITH-OPEN-FILE (IN "/etc/motd")
  (LET (ANS)
    (HANDLER-CASE 
        (LOOP (PUSH (READ-LINE IN) ANS))
      (END-OF-FILE () (NREVERSE ANS)))))
⇒ ("Linux setq 2.6.31-14-generic #48-Ubuntu SMP Fri Oct 16 14:05:01 UTC 2009 x86_64"
 "" "To access official Ubuntu documentation, please visit:"
 "http://help.ubuntu.com/")

2010-01-11

Schemeコードバトンに参加しました R6RS編

| 23:06 | Schemeコードバトンに参加しました R6RS編 - わだばLisperになる を含むブックマーク はてなブックマーク - Schemeコードバトンに参加しました R6RS編 - わだばLisperになる

第1回 Scheme コードバトンのお知らせ - higepon blog

yshigeruさんからのバトン。

CLでフォークしやつ以外の本流のR6RSのバージョンも回ってきてしまいました。

最初、処理系は、Larcenyにしてみようかなと思いましたが、SRFI-37がなく、今迄の変更の良いところがなくなるのでとりやめ。

Schemeコードバトンに参加しました

| 19:12 | Schemeコードバトンに参加しました - わだばLisperになる を含むブックマーク はてなブックマーク - Schemeコードバトンに参加しました - わだばLisperになる

第1回 Scheme コードバトンのお知らせ - higepon blog

前回CLでフォークしたと書いてましたが、具体的にどういう風に変更したか、さっぱり書いてなかったので追記します!

  • higeponさんから最初のバトンを渡されました(CLにフォークしました)
  • 渡されたバトン http://gist.github.com/273431
  • 次はaka(計算機とその周辺: What I Talk About When I Talk About Computers)さんへ
  • 渡したバトン http://gist.github.com/273441
  • やったことは、higeponさんのコードがmosh用だったので、CLで動くように変更
  • 変更点
    1. リストを読み込んで、結果のリストを返すという方式から、順次リストを読み込んで、要素を破壊的に変更する方針に単純化
    2. matchが使えれば良かった
      1. destructuring-bindでがんばる
      2. これ位のデータ構造ならcar、cdrで良いんじゃないか
      3. アクセッサが欲しいのでdefstructで構造を定義
    3. Y/N/Q以外の動作が未規定だったので、Y/N/Q以外はgotoループで再問合わせすることにした

2010-01-10

第1回 Scheme コードバトンのお知らせ

| 20:47 | 第1回 Scheme コードバトンのお知らせ - わだばLisperになる を含むブックマーク はてなブックマーク - 第1回 Scheme コードバトンのお知らせ - わだばLisperになる

higeponさん曰く、

Scheme のコードをバトンのように回していき面白い物ができあがるのを楽しむ遊びを始めました。
盛り上がるようであれば次回 Shibuya.lisp で成果を発表したいと思っています。

とのことだったので、CLの流れでフォークしました。

現在 higepon -> g000001(CL) とバトンが渡っています。

(Scheme->Schemeは、higepon -> yadokarielectric とバトンが渡っています。 )

ここから、Arcに流すか、Clojureに流すか、CLに流れるか、Emacs Lispになるか、は謎です。

もしご興味のある方がいらっしゃいましたら、コメントで表明していただくとバトンが回ってくる対象となります。

とても短いコードをいじっていくので 初心者の方でも参加歓迎です。(分からない事があればフォローします。)

詳細はこちらをどうぞ。

CL版:

http://gist.github.com/273441

R6RS Scheme製オリジナル:

http://gist.github.com/273431

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

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

前回のエントリーも依然としてカオスかなあと思ったので、lequeさんのエントリーも参照しつつ、さらに単純にしてみました。

よくよく考えてみると、単語のエントリーを破壊的に変更していくのが楽ですね。

(defpackage :hige
  (:use :cl))

(in-package :hige)

(defstruct (entry (:type list))
  word meaning ok-count ng-count)

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

(defun nomalize-dict (dict)
  (mapcar (lambda (e)
            (make-entry :word (entry-word e) 
                        :meaning (entry-meaning e)
                        :ok-count (or (entry-ok-count e) 0)
                        :ng-count (or (entry-ng-count e) 0)))
          dict))

(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 word-spec*
        #'>
        :key (lambda (e) 
               (- (entry-ng-count e) (entry-ok-count e)))))

(defun query ()
  (prog2                       ;1年に1度も遭遇するかしないかのprog2が使いたい状況
    (clear-input *query-io*)
    (read-char *query-io*)
    (clear-input *query-io*)))

(defun pr (&rest args)
  (apply #'format *query-io* args))

(defun ready? ()
  (read-char *query-io*))

;; main
(defun main (file)
  (let ((dict (sort-word-spec* (read-dict file))))
    (dolist (e dict)
      (pr "~&~A: " (entry-word e))
      (ready?)    
      (pr "~&~A y/n? " (entry-meaning e))
    :again
      (case (query)
        ((#\Y #\y) (incf (entry-ok-count e)))
        ((#\N #\n) (incf (entry-ng-count e)))
        ((#\Q #\q) (return))
        (otherwise
           (pr "~&Please type Y for yes or N for no or Q for quit.~%")
           (go :again))))
    (write-dict file dict)))

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

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

前回のエントリーのコードだとカオス過ぎるかなと思ったので、心の赴くままに関数を分解してみました。

対話周りは、折角のCLなのでコンディションシステムを使って処理した方が良いような気もしています。

(defpackage :hige
  (:use :cl)
  (:import-from :kmrcl :aand :it)
  (:import-from :shibuya.lisp :fn))

(in-package :hige)

(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 (loop :for (word meaning ok-count ng-count) :in word-spec*
              :collect (list word meaning (or ok-count 0) (or ng-count)))
        #'>
        :key (fn ((ign ore ok-count ng-count))
               (- ng-count ok-count))))

(defun ask (catch-tag 
            result-spec* word-spec
            word more meaning ok-count ng-count)
  (flet ((*query ()
           (clear-input *query-io*)
           (prog1 (read-char *query-io*)
                  (clear-input *query-io*)))
         (*pr (&rest args)
           (apply #'format *query-io* args))
         (*ready? () (read-char *query-io*)))
    (tagbody 
       (*pr "~A: " word)
       (*ready?)    
       (*pr "~A y/n? " meaning)
     :again
       (return-from ask
         (case (*query)
           ((#\y #\Y) (list word meaning (1+ ok-count) ng-count))
           ((#\n #\N) (list word meaning ok-count (1+ ng-count)))
           ((#\q #\Q) (throw catch-tag 
                        `(,@result-spec* ,word-spec ,@more)))
           (otherwise
              (*pr "~&Please type Y for yes or N for no or Q for quit.~%")
              (go :again)))))))

;; main
(defun main (file)
  (aand (read-dict file)
        (catch 'break
          (loop :for (word-spec . more) :on (sort-word-spec* it)
                :for (word meaning ok-count ng-count) := word-spec
                  :collect (ask 'break
                                result-spec* word-spec
                                word more meaning ok-count ng-count)
                     :into result-spec*
                :finally (return result-spec*)))
        (write-dict file it)))

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であれこれというタイプです。

KMRCLを眺める (62) READ-FILE-TO-STRINGS

| 12:40 | KMRCLを眺める (62) READ-FILE-TO-STRINGS - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (62) READ-FILE-TO-STRINGS - わだばLisperになる

今回はKMRCLのio.lisp中からREAD-FILE-TO-STRINGSです。

前回のREAD-STREAM-TO-STRINGSをWITH-OPEN-FILEで包んだものです。

定義は、

(defun read-file-to-strings (file)
  "Opens a reads a file. Returns the contents as a list of strings"
  (with-open-file (in file :direction :input)
    (read-stream-to-strings in)))

となっています。

使用例は、

(DEFVAR *WORDS*
  (READ-FILE-TO-STRINGS "/usr/share/dict/words"))

(LENGTH *WORDS*)
;⇒ 98569

(FILTER (LAMBDA (LINE)
          (UNLESS (EQUAL "" LINE)
            (CHAR= #\Z (CHAR LINE 0))))
        *WORDS*)
⇒ ("Z" "Z's" "Zachariah" "Zachariah's" "Zachary" "Zachary's" "Zachery"
 "Zachery's" "Zagreb" "Zagreb's" "Zaire" "Zaire's" "Zairian" "Zairians"
 "Zambezi" "Zambezi's" "Zambia" "Zambia's" "Zambian" "Zambians" "Zamboni"
 "Zamenhof" "Zamenhof's" "Zamora" "Zamora's" "Zane" "Zane's" "Zanuck"
 "Zanuck's" "Zanzibar" "Zanzibar's" "Zapata" "Zapata's" "Zaporozhye"
 "Zaporozhye's" "Zapotec" "Zapotec's" "Zappa" "Zappa's" "Zebedee" "Zebedee's"
 "Zechariah" "Zechariah's" "Zedekiah" "Zedekiah's" "Zedong" "Zedong's"
 "Zeffirelli" "Zeffirelli's" "Zeke" "Zeke's" "Zelig" "Zelig's" "Zelma"
 "Zelma's" "Zen" "Zen's" "Zenger" "Zenger's" "Zeno" "Zeno's" "Zens" "Zephaniah"
 "Zephaniah's" "Zephyrus" "Zephyrus's" "Zeppelin" "Zeppelin's" "Zest" "Zest's"
 "Zeus" "Zeus's" "Zhengzhou" "Zhivago" "Zhivago's" "Zhukov" "Zhukov's" "Zibo"
 "Zibo's" "Ziegfeld" "Ziegfeld's" "Ziegler" "Ziegler's" "Ziggy" "Ziggy's"
 "Zimbabwe" "Zimbabwe's" "Zimbabwean" "Zimbabweans" "Zimmerman" "Zimmerman's"
 "Zinfandel" "Zinfandel's" "Zion" "Zion's" "Zionism" "Zionism's" "Zionisms"
 "Zionist" "Zionist's" "Zionists" "Zions" "Ziploc" "Zn" "Zn's" "Zoe" "Zoe's"
 "Zola" "Zola's" "Zollverein" "Zollverein's" "Zoloft" "Zomba" "Zomba's" "Zorn"
 "Zorn's" "Zoroaster" "Zoroaster's" "Zoroastrian" "Zoroastrianism"
 "Zoroastrianism's" "Zoroastrianisms" "Zorro" "Zorro's" "Zosma" "Zosma's" "Zr"
 "Zr's" "Zsigmondy" "Zsigmondy's" "Zubenelgenubi" "Zubenelgenubi's"
 "Zubeneschamali" "Zubeneschamali's" "Zukor" "Zukor's" "Zulu" "Zulu's" "Zulus"
 "Zuni" "Zwingli" "Zwingli's" "Zworykin" "Zworykin's" "Zyrtec" "Zyrtec's"
 "Zyuganov" "Zyuganov's" "Zürich" "Zürich's")

位のところでしょうか

ファイルをオープンして行ごとに処理していくのも良いとは思いますが、LIST処理言語LISPとしては、一旦リストにしてしまうと色々素材の料理が楽ですね。

2010-01-08

KMRCLを眺める (61) READ-STREAM-TO-STRINGS

| 01:45 | KMRCLを眺める (61) READ-STREAM-TO-STRINGS - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (61) READ-STREAM-TO-STRINGS - わだばLisperになる

今回はKMRCLのio.lisp中からREAD-STREAM-TO-STRINGSです。

ストリームをREAD-LINEで読んでリストにして返す関数で、定義は

(defun read-stream-to-strings (in)
  (let ((lines '())
        (eof (gensym)))
    (do ((line (read-line in nil eof)
               (read-line in nil eof)))
        ((eq line eof))
      (push line lines))
    (nreverse lines)))

となっています。

使い方は、

(import '(shibuya.lisp:$))

(with-open-file (in "/etc/motd")
  (let ((n 0))
    (map nil ($ format t "~D ~A~%" (incf n) $)
         (READ-STREAM-TO-STRINGS in))))
;->
1 Linux setq 2.6.31-14-generic #48-Ubuntu SMP Fri Oct 16 14:05:01 UTC 2009 x86_64
2 
3 To access official Ubuntu documentation, please visit:
4 http://help.ubuntu.com/

という感じでしょうか。

自分だと、DOから抜ける前に、linesをNREVERSEしてしまいそうですが、抜けてからNREVERSEしているのは、読み易さへの配慮かもしれません。

ちなみに、doはletの機能も持ち合せているので、

(defun read-stream-to-strings (in)
  (do* ((eof (gensym))
        (lines '() (cons line lines))
        (line (read-line in nil eof)
              (read-line in nil eof)))
      ((eq line eof) (nreverse lines))))

という風にも書けますが、DOに馴れてないと読み辛いためか、LETとDOは分離する人が多いかもしれません。

しかし、DOを使いまくっている人のコードや、CLtL2のコード例では合体しているのが多いので、馴れればどうということもない気もします。

2010-01-06

KMRCLを眺める (60) READ-FILE-TO-USB8-ARRAY

| 21:24 | KMRCLを眺める (60) READ-FILE-TO-USB8-ARRAY - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (60) READ-FILE-TO-USB8-ARRAY - わだばLisperになる

今回はKMRCLのio.lisp中からREAD-FILE-TO-USB8-ARRAYです。

usb8ってなんだという感じですが、(unsigned-byte 8)の略のようです。なるほど。

定義は

(defun read-file-to-usb8-array (file)
  "Opens a reads a file. Returns the contents as single unsigned-byte array"
  (with-open-file (in file :direction :input :element-type '(unsigned-byte 8))
    (let* ((file-len (file-length in))
           (usb8 (make-array file-len :element-type '(unsigned-byte 8)))
           (pos (read-sequence usb8 in)))
      (unless (= file-len pos)
        (error "Length read (~D) doesn't match file length (~D)~%" pos file-len))
      usb8))

となっていて、

  1. (unsigned-byte 8)でファイルを開く
  2. file-lengthでサイズを測定
  3. サイズ長のベクタをmake-arrayで作成して
  4. read-sequenceでそのベクタに読み込んで格納

というのが大まかな流れです。

試しに

いろはにほへと
ちりぬるを
わかよたれそ
つねならむ
うゐのおくやま
けふこえて
あさきゆめみし
ゑひもせす

という内容のファイルをUTF-8で/tmp/foo.txtに作成して読み込んでみると

(DEFVAR *IROHA*
  (READ-FILE-TO-USB8-ARRAY "/tmp/foo.txt"))

*IROHA*
;=>#(227 129 132 227 130 141 227 129 175 227 129 171 227 129 187 227 129 184 227
     129 168 10  227 129 161 227 130 138 227 129 172 227 130 139 227 130 146 10 227
     130 143 227 129 139 227 130 136 227 129 159 227 130 140 227 129 157 10  227
     129 164 227 129 173 227 129 170 227 130 137 227 130 128 10  227 129 134 227
     130 144 227 129 174 227 129 138 227 129 143 227 130 132 227 129 190 10  227
     129 145 227 129 181 227 129 147 227 129 136 227 129 166 10  227 129 130 227
     129 149 227 129 141 227 130 134 227 130 129 227 129 191 227 129 151 10  227
     130 145 227 129 178 227 130 130 227 129 155 227 129 153 10)

(JP:GUESS *IROHA*)
;⇒ :UTF-8

(JP:DECODE *IROHA* :GUESS)
;⇒ 
"いろはにほへと
ちりぬるを
わかよたれそ
つねならむ
うゐのおくやま
けふこえて
あさきゆめみし
ゑひもせす
"

という風になります。

※jp:decodeについては、逆引きCommon Lisp/外部からの入力バイト列を文字列にしたい(文字コード変換含む)参照

2010-01-05

KMRCLを眺める (59) READ-FILE-TO-STRING

| 21:53 | KMRCLを眺める (59) READ-FILE-TO-STRING - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (59) READ-FILE-TO-STRING - わだばLisperになる

今回はKMRCLのio.lisp中からREAD-FILE-TO-STRINGです。

前回定義したいREAD-STREAM-TO-STRINGをWITH-OPEN-FILEでラップしてファイルを扱えるようにしたものです。

(defun read-file-to-string (file)
  "Opens a reads a file. Returns the contents as a single string"
  (with-open-file (in file :direction :input)
    (read-stream-to-string in)))

動作は、

(READ-FILE-TO-STRING "/etc/motd")
;⇒ 
"Linux setq 2.6.31-14-generic #48-Ubuntu SMP Fri Oct 16 14:05:01 UTC 2009 x86_64

To access official Ubuntu documentation, please visit:
http://help.ubuntu.com/
"

という感じです。

READ-STREAM-TO-STRINGをラップしているだけに、前回問題にした改行が余計につくことがある問題も当然引き継いでいます。

2010-01-04

KMRCLを眺める (58) READ-STREAM-TO-STRING

| 02:42 | KMRCLを眺める (58) READ-STREAM-TO-STRING - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (58) READ-STREAM-TO-STRING - わだばLisperになる

今回はKMRCLのio.lisp中からREAD-STREAM-TO-STRINGです。

名前の通り、ストリームをREADして文字列にするというもので定義は、

(defun read-stream-to-string (in)
  (with-output-to-string (out)
    (let ((eof (gensym)))
      (do ((line (read-line in nil eof)
                 (read-line in nil eof)))
          ((eq line eof))
        (format out "~A~%" line)))))

です。

利用法は、

(WITH-OPEN-FILE (IN "/etc/motd")
  (READ-STREAM-TO-STRING IN))
;⇒ 
"Linux setq 2.6.31-14-generic #48-Ubuntu SMP Fri Oct 16 14:05:01 UTC 2009 x86_64

To access official Ubuntu documentation, please visit:
http://help.ubuntu.com/

"

のようになると思います。

前回は、EOFの判定に(cons 'eof)を使っていましたが、今回は、(gensym)しているようです。

ふと思ったのですが、上のコードだと最後の行が改行で終っているか否かを区別していないようです。

(WITH-INPUT-FROM-STRING (IN "いろはにほへとちりぬるをわかよたれそつねならむ")
  (READ-STREAM-TO-STRING IN))
;⇒ "いろはにほへとちりぬるをわかよたれそつねならむ
"

とすると改行が新たに追加されていることが分かります。

READ-LINEはEOFが来たときに、改行がなかったかどうかを多値の2値目で返すようになっていることもあり、折角なのでこれを判定してみることにしました。

(DEFUN MY-READ-STREAM-TO-STRING (IN)
  (WITH-OUTPUT-TO-STRING (OUT)
    (PROG ((EOF (GENSYM)) 
           LINE MISSING-NEWLINE-P)
       L  (SETF (VALUES LINE MISSING-NEWLINE-P)
                (READ-LINE IN NIL EOF))
          (WHEN (EQ LINE EOF) (RETURN NIL))
          (FORMAT OUT "~A~:[~%~;~]" LINE MISSING-NEWLINE-P)
          (GO L))))

DOで書こうと思いましたが、綺麗にまとまらなかったので、よりプリミティブなPROGで書いてみました。

(WITH-INPUT-FROM-STRING (IN "いろはにほへとちりぬるをわかよたれそつねならむ")
  (MY-READ-STREAM-TO-STRING IN))
;⇒ "いろはにほへとちりぬるをわかよたれそつねならむ"

という風に気合を入れてPROGで書きましたが、LOOPで普通に書けました…

MULTIPLE-VALUE-LISTでリストを作ったりするとちょっと遅くなるんじゃないかなと思いましたが、速度とコンスを計測してみると(SETF (VALUES))と変わらないみたいですね。

(DEFUN MY-READ-STREAM-TO-STRING (IN)
  (WITH-OUTPUT-TO-STRING (OUT)
    (LOOP :FOR (LINE MISSING-NEWLINE-P) 
            := (MULTIPLE-VALUE-LIST (READ-LINE IN NIL))
          :UNLESS LINE :RETURN NIL
          :DO (FORMAT OUT "~A~:[~%~;~]" LINE MISSING-NEWLINE-P))))

DOでも普通に書けました…

(DEFUN MY-READ-STREAM-TO-STRING (IN)
  (WITH-OUTPUT-TO-STRING (OUT)
    (DO ((LINEL (MULTIPLE-VALUE-LIST (READ-LINE IN NIL))
                (MULTIPLE-VALUE-LIST (READ-LINE IN NIL))))
        ((NOT (CAR LINEL)))
      (FORMAT OUT "~{~A~:[~%~;~]~}" LINEL))))

2010-01-03

Clojure 1.1のdo-templateをCLで

| 03:22 | Clojure 1.1のdo-templateをCLで - わだばLisperになる を含むブックマーク はてなブックマーク - Clojure 1.1のdo-templateをCLで - わだばLisperになる

no titleを観てみると、Clojure 1.1には色々と機能が追加されたみたいようです。

4つ位機能が紹介されていますが、do-templateはCommon Lispですぐ真似できそうだったので早速マクロを書いてみました。

(USE-PACKAGE :SHIBUYA.LISP)

(DEFUN SUBST* (NEWS OLDS TREE &KEY (TEST #'EQL TESTP) 
                                   (TEST-NOT #'EQL NOTP))
  (WHEN (AND TESTP NOTP)
    (ERROR ":TEST and :TEST-NOT were both supplied."))
  (IF (OR (ENDP NEWS) (ENDP OLDS))
      TREE
      (SUBST* (CDR NEWS) (CDR OLDS)
              (APPLY #'SUBST (CAR NEWS) (CAR OLDS) 
                     TREE (IF NOTP 
                              (LIST :TEST-NOT TEST-NOT)
                              (LIST :TEST TEST))))))

(DEFMACRO DO-TEMPLATE ((&REST VARS) EXPR &REST VALS)
  `(PROGN ,@(MAPCAR (CUT SUBST* <> VARS EXPR)
                    (GROUP VALS (LENGTH VARS)))))

使い方は、

(DO-TEMPLATE (NAME INC)

  (DEFUN NAME (N)
    (+ N INC))
  
  FOO 2
  BAR 3
  BAZ 4)

とテンプレートの定義を書くと、

(PROGN
  (DEFUN FOO (N) (+ N 2))
  (DEFUN BAR (N) (+ N 3))
  (DEFUN BAZ (N) (+ N 4)))

と展開されます。

マクロがあるのに、なんでわざわざという気もしますが、マクロのデザイン・パターンの一つとして考えれば、こういうのも悪くないかなと思いました。

Common Lispでは、do-templateは、

(MACROLET ((DE (NAME INC)
             `(DEFUN ,NAME (N)
                (+ N ,INC))))
  (DE FOO 2)
  (DE BAR 3)
  (DE BAZ 4))

とでも書けるかなと思います。

KMRCLを眺める (57) PRINT-FILE-CONTENTS

| 00:03 | KMRCLを眺める (57) PRINT-FILE-CONTENTS - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (57) PRINT-FILE-CONTENTS - わだばLisperになる

lists.lispも読み終わったので次は何にしようと思いましたが、とりあえず手頃なところで入出力関係のio.lispを眺めて行くことにしました。

ということで、今回はKMRCLのio.lisp中からPRINT-FILE-CONTENTSです。

名前の通り、ファイルの中身をPRINTするというもので定義は、

(defun print-file-contents (file &optional (strm *standard-output*))
  "Opens a reads a file. Returns the contents as a single string"
  (when (probe-file file)
    (let ((eof (cons 'eof nil)))
      (with-open-file (in file :direction :input)
        (do ((line (read-line in nil eof)
                   (read-line in nil eof)))
            ((eq line eof))
          (write-string line strm)
          (write-char #\newline strm))))))

です。

動作は想像どおり、

(WITH-OUTPUT-TO-STRING (OUT)
  (PRINT-FILE-CONTENTS "/etc/motd" OUT))
;⇒ "Linux setq 2.6.31-14-generic #48-Ubuntu SMP Fri Oct 16 14:05:01 UTC 2009 x86_64
;
;To access official Ubuntu documentation, please visit:
;http://help.ubuntu.com/
;
;"

です。

定義中の

((eof (cons 'eof nil)))

が何か妙な気がしますが、READ-LINEがEOFになった時に返すオブジェクト((EOF)というリスト)を作成しています。

呼ばれる度にconsされるので一意になる筈、ということなんだと思います(ということでeqで比較)が、たまにこういうスタイルを見かける気がします。

NILや:EOF、'eofでも特に問題に遭遇したことはないのですが、何かあったりするんでしょうか。(READなら色々あると思いますが…)

他のパターンでは、ストリームオブジェクトそのものを判定に使うというのがあるようです。

(with-open-file (in file :direction :input)
  (do ((line (read-line in nil in)
             (read-line in nil in)))
      ((eq line in))
    (write-string line strm)
    (write-char #\newline strm)))))

最初にこのやり方を聞いたときに、ナイスなアイデアだと思うと同時に、本当にそんなひねくれたことをする人がいるのか、と思いましたが、Common Lispプログラミング/Rodney-Brooksでも紹介されていた手法なので割と古くからあるスタイルなのかもしれません。

2010-01-02

KMRCLを眺める (56) UNIQUE-SLOT-VALUES

| 00:33 | KMRCLを眺める (56) UNIQUE-SLOT-VALUES - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (56) UNIQUE-SLOT-VALUES - わだばLisperになる

今回は、KMRCLのlists.lisp中からUNIQUE-SLOT-VALUESです。

lists.lispは今回で終了。

名前からするとスロットの値をどうこうするという感じですが、どのあたりがリストユーティリティなのか謎です。

定義は

(defun unique-slot-values (list slot &key (test 'eql))
  (let ((uniq '()))
    (dolist (item list (nreverse uniq))
      (let ((value (slot-value item slot)))
        (unless (find value uniq :test test)
          (push value uniq))))))

という感じで、この定義から使い方を察すると

(IMPORT '(SHIBUYA.LISP:CUT SHIBUYA.LISP:<>))

;; Aというスロットを持つオブジェクトを定義
(DEFCLASS FOO ()
  ((A :INITFORM 0 :INITARG :A)))

;; スロットAの値が、1 2 3 4 5 4 3 2 1のインスタンスを作成し
;; リストに格納
(DEFVAR *INSTANCES*
  (MAPCAR (CUT MAKE-INSTANCE 'FOO :A <>)
          '(1 2 3 4 5 4 3 2 1)))

;; スロットの中身を確認
(MAPCAR (CUT SLOT-VALUE <> 'A) 
        *INSTANCES*)
;=> (1 2 3 4 5 4 3 2 1)

;; UNIQUE-SLOT-VALUESを使ってみる
(UNIQUE-SLOT-VALUES *INSTANCES* 'A)
;=> (1 2 3 4 5)

色々なインスタンスの同名のスロットの中を覗いて値の重複を除外したものを集める関数のようです。

一体、どういうところに使うんでしょう…。

2010-01-01

Shibuya.lispという名前でCLのユーティリティ集を始めてみました

| 21:10 | Shibuya.lispという名前でCLのユーティリティ集を始めてみました - わだばLisperになる を含むブックマーク はてなブックマーク - Shibuya.lispという名前でCLのユーティリティ集を始めてみました - わだばLisperになる

自分は、ユーティリティ集が大好きなのですが、つねづね自分でも作ってみたいと思っていました。

最近Githubがはやっているので、ここで皆でごちゃごちゃ作ると楽しいのではないかなと思い、Shibuya.lispという人が釣れそうな名前で行くことにしてみました。

勝手に名付けて怒られそうですが、許して下さい。

  • 自分で考えた俺構文や、便利関数も普段から使ってみないと良いアイデアなのか分からないことが多いので、それなりにライブラリに纒めて簡単に使えるようにしておきたい。
  • 自作のユーティリティだとブログ等に書く際に注釈を入れたりしないといけないので、どっかに纒めて誰でも使えるようにして置くと楽そう
  • みんなで作るとカオスになって楽しそう
  • たまたま、githubだと、asdf-installでのインストールが楽だった

という辺りが動機です。

場所は、

です。

パッケージ名は、shibuya.lisp、ニックネームは、slなので、

(sl:listq a b c d)
;⇒ (A B C D)

などと短かく書けて良いかなと思います。

また、自作のユーティリティだとブログ等に書く際に注釈を入れたりしないといけない、というのは、

(require :shibuya.lisp) ; (asdf:oos 'adsf:load-op :shibuya.lisp)
(use-package :shibuya.lisp)

(mapcar (cut * <> 3)
        '(1 2 3 4))
;⇒ (3 6 9 12)

などとインポートする手順だけを書くことによって定義の説明を省けることを期待しています。

インストールは、ASDFを利用している人は、

(asdf-install:install "http://github.com/g000001/shibuya.lisp/tarball/master")

でOKで、常に最新のものがインストールされます。

自分は、gitの使い方が分からないので色々失敗すると多いと思いますが、どんどん取り込む方針ですので、興味があったら是非参加してみて下さい。

リーダーマクロの共有は、完全にカオスになりそうなので別ファイルにしていますが、named-readtables等を使って整理できれば良いかなと考えています。

KMRCLを眺める (55) UPDATE-PLIST

| 00:37 | KMRCLを眺める (55) UPDATE-PLIST - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (55) UPDATE-PLIST - わだばLisperになる

今回は、KMRCLのlists.lisp中からUPDATE-PLISTです。

以前のUPDATE-ALISTと同じくPLISTの内容を変更するユーティリティです。

定義は、

(defmacro update-plist (pkey value plist &key (test '#'eql))
  "Macro to support below (setf get-alist)"
  (let ((pos (gensym)))
    `(let ((,pos (member ,pkey ,plist :test ,test)))
       (if ,pos
           (progn
             (setf (cadr ,pos) ,value)
             ,plist)
         (setf ,plist (append ,plist (list ,pkey ,value)))))))

となっていて、これもUPDATE-ALISTと同じくマクロじゃなくて良い気がしますが、マクロになっています。

更新にはMEMBERで返ってきた値をつかうのですが、これだと、

(DEFPARAMETER *PLIST* (LIST :A 1 :B 2 :C 3 :D 4))

(UPDATE-PLIST 1 :FOO! *PLIST*)

*PLIST*
;⇒ (:A 1 :FOO! 2 :C 3 :D 4)

値の部分もキーとみなされてその次が更新されてしまうことになります…。

ということで良い機会なので自分も試しに作ってみました。

マクロではなくて関数にしています。

(DEFUN MY-UPDATE-PLIST (PKEY VALUE PLIST &KEY (TEST #'EQL))
  (IF (ENDP PLIST)
      (LIST PKEY VALUE)
      (DO ((PL PLIST (CDDR PL))
           (TAIL NIL PL)
           (MODIFYP NIL))
          ((ENDP PL) (PROG1 PLIST
                            (UNLESS MODIFYP 
                              (NCONC TAIL (LIST PKEY VALUE)))))
        (WHEN (FUNCALL TEST PKEY (CAR PL))
          (SETF (CADR PL) VALUE
                MODIFYP 'T)))))

UPDATE-PLISTはドキュメントストリングにも"Macro to support below (setf get-alist)"とタイポがあったり(そして、その(setf get-plistは存在しない…))で、なんとなくなげやりに作られたように思えます('-'*)