調べるのに少し手間取ったのでメモ。

Common Lispだと

(getf (list :a 1 :b 2 :c 3) :a)
;;=> 1

これのScheme版はget-keyword。

(get-keyword :a (list :a 1 :b 2 :c 3))
;;=> 1

属性リストって書くの楽でいいよなぁ。他の言語でこんなのやると罪悪感みたいのがわくけど、 こっちは関数があるおかげで「使っていいんだ」っていう雰囲気。

% md5sum ~/gauche-refj.txt.gz
31970f62bbb827c8fc14ebae6a132b25  /home/yz/gauche-refj.txt.gz

これをやりたいんだ。

Rubyだと

require 'digest/md5'
puts Digest::MD5.hexdigest(File.read("/home/yz/gauche-refj.txt.gz"))
#=> "31970f62bbb827c8fc14ebae6a132b25"を表示

で済むんだけど、Rubyでぬくぬくしてるとそろそろゆとり脳って言われそうなのでひさしぶりにGaucheで頑張る。

(use rfc.md5)
(use file.util)
(print (digest-hexify (md5-digest-string (file->string "/home/yz/gauche-refj.txt.gz"))))
;=> "6ff4b0c6979cb79d21e355d338769d5b"を表示

なんか違う。file->stringがFile.readとは違うみたい。

rfc/md5.scmから適度にパクってこうなった。

(use rfc.md5)
(use gauche.uvector)

(define *buffer-len* (* 1024 10)) ; 10KB

(define (file->md5-digest path)
  (let ((buf (make-u8vector *buffer-len*))
        (md5 (make <md5>)))
    (call-with-input-file path 
                          (lambda (port)
                            (until (read-block! buf port) eof-object? => cnt
                              (digest-update! md5
                                              (u8vector->string (if (< cnt *buffer-len*)
                                                                  (uvector-alias <u8vector> buf 0 cnt)
                                                                  buf))))
                            (digest-final! md5)))))

(print (digest-hexify (file->md5-digest "/home/yz/gauche-refj.txt.gz")))
;=> "31970f62bbb827c8fc14ebae6a132b25"を表示

なげぇw けどdigest関係の必要な関数が把握できた。ｳﾌﾌ

Scheme(Gauche)

gosh> (let (x y) (list x y))
*** ERROR: Compile Error: syntax-error: malformed let: (let (x y) (list x y))
"(stdin)":1:(let (x y) (list x y))

Common Lisp(clisp)

[1]> (let (x y) (list x y))
(NIL NIL)

へぇ。

なんだか読んだ気がしないが。

(´Д`)つ

これはなかなか良い入門本だった。 見かけにだまされてはいけない。

オレは1年くらい前にScheme入門済みのはずだったんだけど、 Chapter 8の継続渡しとChapter 9のY Combinatorは 名前知ってるだけの状態だったので簡単にはいかなかった。

続編のThe Seasoned Schemerを勢いで購入してみた。 そして積む。

(´Д`)つ

さらさらっと眺めた。

(´Д`)つ

かなり影響を受けた。 関係ないけど、説明がとてもすんなり入ってくる小気味の良い本だったような気がする。

あー、いい加減なレビューだな。

図書館に返さないといけないので、 あとでわかるようにThe Little SchemerのY combinatorの導出過程をなぞったやつをメモメモ。

Little Schemerはlengthでやってたけど、ここではリストの和を返す手続きを作ってみる。 「それapplyでできるよ！」ってのは置いといて。

(use gauche.test)

(define (eternity x)
  (eternity x))

(test-section "lambda, lambda, lambda, ...")

; 長さ0のリストの和までおk
(define sum0-a
  ((lambda (sum)
     (lambda (l)
       (cond ((null? l) 0)
             (else (+ (car l) (sum (cdr l)))))))
   eternity))

; 長さ1のリストの和までおk
(define sum1-a
  ((lambda (sum)
     (lambda (l)
       (cond ((null? l) 0)
             (else (+ (car l) (sum (cdr l)))))))
   sum0-a))

; 長さ2のリストの和までおk
(define sum2-a
  ((lambda (sum)
     (lambda (l)
       (cond ((null? l) 0)
             (else (+ (car l) (sum (cdr l)))))))
   sum1-a))

(test "sum0-a" 0 (cut sum0-a '()))
(test "sum1-a" 1 (cut sum1-a '(1)))
(test "sum1-a" 3 (cut sum2-a '(1 2)))

(test-section "lambdaの連鎖をDRY")

(define sum0-b
  ((lambda (mk-sum)
     (mk-sum eternity))
   (lambda (sum)
     (lambda (l)
       (cond ((null? l) 0)
             (else (+ (car l) (sum (cdr l)))))))))

(define sum1-b
  ((lambda (mk-sum)
     (mk-sum
       (mk-sum eternity)))
   (lambda (sum)
     (lambda (l)
       (cond ((null? l) 0)
             (else (+ (car l) (sum (cdr l)))))))))

(define sum2-b
  ((lambda (mk-sum)
     (mk-sum
       (mk-sum
         (mk-sum eternity))))
   (lambda (sum)
     (lambda (l)
       (cond ((null? l) 0)
             (else (+ (car l) (sum (cdr l)))))))))

(test "sum0-b" 0 (cut sum0-b '()))
(test "sum1-b" 1 (cut sum1-b '(1)))
(test "sum1-b" 3 (cut sum2-b '(1 2)))

(test-section "eternityの代わりにmk-sumを")

(define sum0-c
  ((lambda (mk-sum)
     (mk-sum mk-sum))
   (lambda (sum)
     (lambda (l)
       (cond ((null? l) 0)
             (else (+ (car l) (sum (cdr l)))))))))

(test "sum0-c" 0 (cut sum0-c '()))

(test-section "このsumはmk-sumだよね")

(define sum0-d
  ((lambda (mk-sum)
     (mk-sum mk-sum))
   (lambda (mk-sum)
     (lambda (l)
       (cond ((null? l) 0)
             (else (+ (car l) (mk-sum (cdr l)))))))))

(test "sum0-d" 0 (cut sum0-d '()))

(test-section "mk-sumの引数はリストじゃなくて。ちなみにこれで再帰が1回増やせる")

(define sum1-e
  ((lambda (mk-sum)
     (mk-sum mk-sum))
   (lambda (mk-sum)
     (lambda (l)
       (cond ((null? l) 0)
             (else (+ (car l) ((mk-sum eternity) (cdr l)))))))))

(test "sum1-e" 1 (cut sum1-e '(1)))

(test-section "これで良くね？")

(define sum-f
  ((lambda (mk-sum)
     (mk-sum mk-sum))
   (lambda (mk-sum)
     (lambda (l)
       (cond ((null? l) 0)
             (else (+ (car l) ((mk-sum mk-sum) (cdr l)))))))))

(test "sum-f" 0 (cut sum-f '()))
(test "sum-f" 1 (cut sum-f '(1)))
(test "sum-f" 3 (cut sum-f '(1 2)))
(test "sum-f" 6 (cut sum-f '(1 2 3)))

(test-section "(mk-sum mk-sum)はsum")

(define sum-g
  ((lambda (mk-sum)
     (mk-sum mk-sum))
   (lambda (mk-sum)
     ((lambda (sum)
        (lambda (l)
          (cond ((null? l) 0)
                (else (+ (car l) (sum (cdr l)))))))
      (lambda (x)
        ((mk-sum mk-sum) x))))))

;(define sum-g-eternity
;  ((lambda (mk-sum)
;     (mk-sum mk-sum))
;   (lambda (mk-sum)
;     ((lambda (sum)
;        (lambda (l)
;          (cond ((null? l) 0)
;                (else (+ (car l) (sum (cdr l)))))))
;      (mk-sum mk-sum))))) ; ここで先にループしてしまう

(test "sum-g" 0 (cut sum-g '()))
(test "sum-g" 1 (cut sum-g '(1)))
(test "sum-g" 3 (cut sum-g '(1 2)))
(test "sum-g" 6 (cut sum-g '(1 2 3)))

(test-section "抽出")

(define sum-h
  ((lambda (s)
     ((lambda (mk-sum)
        (mk-sum mk-sum))
      (lambda (mk-sum)
        (s (lambda (x)
             ((mk-sum mk-sum) x))))))
   (lambda (sum)
     (lambda (l)
       (cond ((null? l) 0)
             (else (+ (car l) (sum (cdr l)))))))))

(test "sum-h" 0 (cut sum-h '()))
(test "sum-h" 1 (cut sum-h '(1)))
(test "sum-h" 3 (cut sum-h '(1 2)))
(test "sum-h" 6 (cut sum-h '(1 2 3)))

(test-section "分離")

(define ?
  (lambda (s)
    ((lambda (mk-sum)
       (mk-sum mk-sum))
     (lambda (mk-sum)
       (s (lambda (x)
            ((mk-sum mk-sum) x)))))))

(define sum-i
  (? (lambda (sum)
      (lambda (l)
        (cond ((null? l) 0)
              (else (+ (car l) (sum (cdr l)))))))))

(test "sum-i" 0 (cut sum-i '()))
(test "sum-i" 1 (cut sum-i '(1)))
(test "sum-i" 3 (cut sum-i '(1 2)))
(test "sum-i" 6 (cut sum-i '(1 2 3)))

; これをY combinatorという
(define Y
  (lambda (p)
    ((lambda (f) (f f))
     (lambda (f)
       (p (lambda (x) ((f f) x)))))))

(test-section "lengthを使わないで再帰を定義")

(define length
  (Y (lambda (len)
       (lambda (l)
         (cond ((null? l) 0)
               (else (+ 1 (len (cdr l)))))))))

(test "length 0" 0 (cut length '()))
(test "length 3" 3 (cut length '(1 2 3)))
(test "length 5" 5 (cut length '(1 2 3 4 5)))

(test-end)

うーん、わかったようなそうでもないような。まあ流れだけだなぁ。

さて、また変な時間（21時〜3時）に寝てしまって、変な時間から起きてるわけだが。

On Lispより。

関数は安全に書き換えられないものを返してはいけないということだ． だから返り値にクォート付きオブジェクトを含むような関数を書くのは避けるべきだ．

On Lisp --- 関数的プログラミング

んお。そうなのか。On LispにあるコードをSchemeで試してみる。

(define (exclaim expression)
  (append expression '(oh my)))

(exclaim '(lions and tigers and bears)) 
;;=> (lions and tigers and bears oh my)

(append! (exclaim '(lions and tigers and bears)) '(goodness))
;;=> (lions and tigers and bears oh my goodness)

(exclaim '(lions and tigers and bears))
;;=> (lions and tigers and bears oh my goodness)

おお。exclaimの'(oh my)のcddrがappend!によって変更されてしまうみたい。 クォートした'(oh my)ってのの実体は一体なんなんだろう。

(define (exclaim2 expression)
  (append expression '(oh my)))

(exclaim2 '(lions and tigers and bears))
;;=> (lions and tigers and bears oh my)

別の手続きに'(oh my)を使ってもそちらの'(oh my)は変更されていないようなので、 クオートされたものは手続きごとに環境のような形で持っているんだろうか。 それともそんなまどろっこしいことはなくて、適当にどこかに確保されるだけかな？

まさかこんなことも……。

(define (foo) '(a))

(foo)
;;=> (a)

(set-car! (foo) 3)

(foo)
;;=> (3)

(set-cdr! (foo) 4)

(foo)
;;=> (3 . 4)

Cで言うstaticのついたローカル変数のような、オブジェクト指向言語で言うクラス変数のような。 とにかく呼び出しごとに毎回生成されるものではないみたい。考えたこともなかったよ。

(define (exclaim expression)
  (append expression (list 'oh 'my)))

なら安全。なんとなくそうしてたけど、なるほどねぇ。

木を0,1のラベルにするやつの逆をやってみた。

(use srfi-1)

(define (label->tree label)
  (let loop ((label (cdr (normalize label)))
             (stack (list 1))
             (num 2)
             (pathls '()))
    (cond ((null? label) pathls)
          ((= 1 (car label)) (loop (cdr label) (cdr stack) num pathls))
          ((= 0 (car label))
           (loop (cdr label) (cons num stack) (+ num 1) (cons (list num (car stack))
                                                              pathls))))))

; label->treeがすっきりするようにlabelを変形
(define (normalize label)
  (let1 sp (split-point label)
        (if (= sp (length label)) label
          (append (cons 0 (take label sp))
                  (cdr (drop label sp))))))

(define (split-point label)
  (let loop ((num 1) (sum 0) (l label))
    (let1 n (if (= 0 (car l)) 1 -1)
          (if (= 0 (+ sum n)) num
            (loop (+ num 1) (+ sum n) (cdr l))))))

gosh> (tree->label '((1 3) (2 3) (3 4) (5 6) (6 7) (8 9) (4 10) (7 10) (9 10)))
(0 0 0 0 1 0 1 1 1 0 0 0 1 1 1 0 0 1 1 1)
gosh> (label->tree (list 0 0 0 0 1 0 1 1 1 0 0 0 1 1 1 0 0 1 1 1))
((10 9) (9 1) (8 7) (7 6) (6 1) (5 3) (4 3) (3 2) (2 1))

ノードの番号は当然一致しないけど、同じ木ができたっぽい。もう一個。

gosh> (tree->label '((1 2) (3 4) (2 5) (4 5) (5 6) (7 8) (8 10) (9 10) (5 10)))
(0 0 0 1 1 0 0 1 1 0 1 1 0 0 0 1 1 0 1 1)
gosh> (label->tree (list 0 0 0 1 1 0 0 1 1 0 1 1 0 0 0 1 1 0 1 1))
((10 1) (9 8) (8 1) (7 2) (6 5) (5 2) (4 3) (3 2) (2 1))

同じっぽい。

最近プログラミングしてなかった。 授業で出てきた、木を0,1で表現するアルゴリズムってのが面白そうなのでリハビリということで実装してみた。

(use gauche.collection)
(use srfi-1)

; ex. pathls = ((1 2) (2 3))
(define (tree->label pathls)
  (let loop ((nodes (make-node-list pathls)))
    (cond ((<= (length nodes) 0) (error "why is there no node?"))
          ((= (length nodes) 1) (get-label (car nodes)))
          ((= (length nodes) 2) (apply append (sort (map get-label nodes) label>?)))
          (else
            (let1 non-leaf-nodes (filter (lambda (n) (not (leaf? n))) nodes)
                  (let iter ((nln non-leaf-nodes)
                             (promises '()))
                    (if (null? nln)
                      (begin
                        (for-each force promises)
                        (loop non-leaf-nodes))
                      (begin
                        (let1 node (car nln)
                              (set-label! node (concat-labels node))
                              (iter (cdr nln) (cons (delete-leaves! node) promises)))))))))))

(define (make-node id)
  (list id (list 0 1) '()))

(define (get-label node)
  (cadr node))

(define (get-id node)
  (car node))

(define (get-branches node)
  (caddr node))

(define (get-leaves node)
  (filter leaf? (get-branches node)))

(define (set-label! node label)
  (set-car! (cdr node) label))

(define (leaf? node)
  (>= 1 (length (get-branches node))))

; nodeと隣接する葉を削除するpromiseを返す
; 葉の削除後このnodeが葉になる可能性があり、削除を遅延しておかないと
; ほかのノードのdelete-leaves!でこのnodeが葉と見なされて消されてしまう
(define (delete-leaves! node)
  (let1 non-leaf-nodes (filter (lambda (br) (not (memq br (get-leaves node))))
                               (get-branches node))
        (delay (set-car! (cddr node) non-leaf-nodes))))

; nodeにbranch-nodeへの枝を追加する
(define (add-branch! node branch-node)
  (set-car! (cddr node) (cons branch-node (get-branches node))))

; pathで指定されたノード間をつなぐ ex. path: (1 2)
(define (connect! path nodes)
  (let ((node1 (get-node-by-id (car path) nodes))
        (node2 (get-node-by-id (cadr path) nodes)))
    (add-branch! node1 node2)
    (add-branch! node2 node1)))

(define (label>? label1 label2)
  (> (length label1) (length label2)))

(define (make-node-list pathls)
  (let1 nodes (map make-node (path-list->node-id-list pathls))
        (for-each (cut connect! <> nodes) pathls)
        nodes))

(define (get-node-by-id id nodes)
  (find (lambda (n) (eq? id (get-id n))) nodes))

(define (path-list->node-id-list pathls)
  (delete-duplicates (apply append pathls)))

(define (concat-labels node)
  (append '(0)
          (apply append (sort (cons (cdr (drop-right (get-label node) 1))
                                    (map get-label (get-leaves node)))
                              label>?))
          '(1)))

長いね。

アルゴリズムの詳しい説明はめんどくさいんでしないけど、 大まかに言うとノードにラベルを振って、 葉をそれが隣接するノードのラベルで表現したらその葉を消していくって感じ。 ノードのラベルが変化していくので代入の手続きを使ったけど、 代入はまだまだ慣れないなあ。混乱する。

個人的には遅延評価がうまいこと使えたのがよかったです。いや、うまいのかどうかはわかんね。 使いたかっただけじゃないかと。

ノードが1, 2, ...で、枝を(1 2)とかと表現。

gosh> (tree->label '((1 3) (2 3) (3 4) (5 6) (6 7) (8 9) (4 10) (7 10) (9 10)))　…☆
(0 0 0 0 1 0 1 1 1 0 0 0 1 1 1 0 0 1 1 1)
gosh> (tree->label '((1 2) (3 4) (2 5) (4 5) (5 6) (7 8) (8 10) (9 10) (5 10)))
(0 0 0 1 1 0 0 1 1 0 1 1 0 0 0 1 1 0 1 1)
gosh> (tree->label '((a b) (b c) (c d) (e f) (f d) (d g) (g h) (h i) (h j)))　　…○
(0 0 0 0 1 0 1 1 1 0 0 0 1 1 1 0 0 1 1 1)

木が0, 1で表現できるなんて面白い。 そう言えば、これは木の同型判定アルゴリズムとかいってたな。☆と○が同じ結果だから 同じ木ですってことでいいんだったかな。

ん、待てよ。わざわざdelay使わなくても

(define (delete-leaves! node)
  (let1 non-leaf-nodes (filter (lambda (br) (not (memq br (get-leaves node))))
                               (get-branches node))
        (lambda () (set-car! (cddr node) non-leaf-nodes))))

として、tree->labelのところを

(for-each force promises)
　　↓
(for-each (lambda (p) (p)) delete-proc)

としても同じじゃないか。ハズカシス(´Д⊂)

やっぱり遅延評価はまだ使いどころがわからないっていうか、まず勉強するのが先か。

gaucheのリファレンスのapplyの 引数のところの(arg1 … . args)で意味がわかんなくなってたんだけど、 R5RSを 読んで氷解。

(apply proc arg1 ... args)

proc は手続きでなければならず，args はリストでなければな らない。proc を，リスト(append (list arg1 ... ) args) の各要素を各実引数として呼び出す。

R5RS

なるほど。

(apply proc arg1 ... args)

   ↓

(apply proc (append (list arg1 ...) args))

ということみたいなので

gosh> (apply + '(1 2 3))
6
gosh> (apply + 1 '(2 3))
6
gosh> (apply + 1 2 '(3))
6
gosh> (apply + 1 2 3 '())
6

なるほど。

これでやっと、2次元配列の要素を縦に足すコードの 以下の2つが同じであることに合点がいく。

(define data '((1 2 3) (4 5 6) (7 8 9)))

(apply map (cons + data))
;=> (12 15 18)

(apply map + data)
;=> (12 15 18)

sicp - 結城浩のSICP日記 - リストのリスト

すげー。ここまで短くする脳味噌が早く欲しいです。

で、(append (list arg1 ... arg_n) args)を(arg1 ... arg_n . args)と書けるわけですか。 確かにarg_nのcdrがargs……。うーん、気づかなかった。

gosh> '(1 2 . (3 4 5))
(1 2 3 4 5)

ほんとだ。まだ慣れてないなぁ。

2ちゃんでページを教えてもらいました。 やっぱりグローバルマッチは自分で書くしかないのか……。

(use srfi-42)
(define (rxmatch-all re str)
  (let loop ((r '()) (str str))
    (let1 m (rxmatch re str)
      (if m
        (loop (let1 nmatch (rxmatch-num-matches m)
                (if (= nmatch 1)
                  (cons (m 0) r)
                  (append! (reverse! (list-ec (: i 1 nmatch) (m i))) r)))
              (m 'after))
        (reverse! r)))))

(rxmatch-all #/./ "abc")      ; => ("a" "b" "c")
(rxmatch-all #/.(.)/ "abcde") ; => ("b" "d")

Scheme:初心者の質問箱

なるほど。朝方書いたのは/.(.)/みたいに括弧で 括った部分のみ取り出したい場合を考慮してなかった。

にしても勉強になるなぁ。マッチ部分をreverse!してからrとappend!してるのは append!の計算量が1つ目の引数のリストの個数分かかるから、ですよね。 rのほうが長いリストになることが多いからこれは第1引数にしない、と。 そしてこれ末尾再帰になる、よね。

気になるのはappend!とreverse!の「!」で、第1引数を破壊的に変更するっていう動作だと思うんだけど、 上のコードだと「!」はなくても動くような。何かパフォーマンス的に理由があったりするのかなぁ。

あとlist-ecなにこれ。

gosh> (list-ec (: i 0 10) i)
(0 1 2 3 4 5 6 7 8 9)
gosh> (list-ec (: i 0 10) (* i i))
(0 1 4 9 16 25 36 49 64 81)

あーっ！！　リストを作り出したいときは再帰で回すより絶対楽だ……。

ちなみにRubyのString#scanだと

>> "abcdef".scan(/./)
=> ["a", "b", "c", "d", "e", "f"]
>> "abcdef".scan(/(.)(.)/)
=> [["a", "b"], ["c", "d"], ["e", "f"]]

なので、

(use srfi-42)
(define (rxmatch-all re str)
  (let loop ((r '()) (str str))
    (let1 m (rxmatch re str)
          (if m
            (loop (let1 nmatch (rxmatch-num-matches m)
                        (if (= nmatch 1)
                          (cons (m 0) r)
                          (cons (list (list-ec (: i 1 nmatch) (m i))) r)))
                  (m 'after))
            (reverse r)))))

とすれば

gosh> (rxmatch-all #/./ "abcdefg")
("a" "b" "c" "d" "e" "f" "g")
gosh> (rxmatch-all #/(.)(.)/ "abcdefg")
(("a" "b") ("c" "d") ("e" "f"))

おし。