vallog

2010/02/08

9LISP - 009

9LISP の 009 回目を開催してきました。

午前中は9LISP、午後はKPFの第五回という楽しい一日でした。

内容はshunsukさんのこちらの記事をどうぞ。

9LISP では引き続きThe Little Schemerをテキストとして使用しています。

今回からはテキストを頭から順に進めていくスタイルを止めて、下記ポイントに絞って進めていくことになりました。

高階関数
クロージャ
継続（継続渡し、継続呼び出し）
末尾再帰
マクロ

The Little Schemerでは末尾再帰とマクロについては扱われていませんし、継続渡しスタイル（CPS）の例も複雑で、正直わかりづらいです。

この辺はまたそのうち検討するということで。

継続についてはThe Little Schemerの続きであるThe Seasoned Schemerでページを割いてあるのでそちらも検討してみます。

今回は高階関数の例題を書いてみよー！ということでやってみました。

9LISP の参加者には高階関数やクロージャってなんぞ？な人から、息をするように使う人までいろんな人が参加しています。

高階関数やクロージャというのは、「概念そのものより説明することの方が難しい」という話が前回も出ていました。その点で「値渡しと参照渡し」とか「ポインタ」に似てるよねーと。たぶん継続もそうなんだろうね、ということでした。

ということで、説明うんぬんより実践あるのみということで以下の例題をやりました。

指定した要素をlistから削除するrember関数を定義する（つまりsrif-1のfilterのような関数）。
list内に要素oldが存在した場合、その隣に要素newを挿入するinsert関数を定義する（挿入位置をパラメータの関数に任せる）。

実際にはまず非高階な関数を定義して、高階関数に書き換えてみる、という手順で進めました。

The Little Schemerの流れと同じです。

The Little Schemer - My Snippet

rember（非高階）

(define rember
  (lambda (a lat)
    (cond
     ((null? lat) lat)
     ((eq? a (car lat))(cdr lat))
     (else (cons (car lat)

(rember a (cdr lat)))))))

multirember（非高階）

(define multirember

  (lambda (a lat)
    (cond ((null? lat) lat)
          ((eq? a (car lat)) (multirember a (cdr lat)))
          (else (cons (car lat)(multirember a (cdr lat)))))))

rember*（非高階）

(define rember*

  (lambda (a l)
    (cond ((null? l) l)
          ((atom? (car l)) (cond ((eq? a (car l))(rember* a (cdr l)))
                                 (else (cons (car l)(rember* a (cdr l))))))
          (else (cons (rember* a (car l))
                      (rember* a (cdr l)))))))

rember-f（高階）

(define rember-f

  (lambda (test? a l)
    (cond ((null? l) l)
          ((test? a (car l)) (rember-f test? a (cdr l)))
          (else (cons (car l)
                      (rember-f test? a (cdr l)))))))

rember-f（高階）

(define rember-f

  (lambda (test?)
    (lambda (a l)
      (cond ((null? l) l)
            ((test? a (car l))((rember-f test?) a (cdr l)))
            (else (cons (car l)
                        ((rember-f test?) a (cdr l))))))))

multirember-f（高階）

(define multirember-f

  (lambda (test?)
    (lambda (a lat)
      (cond ((null? lat) lat)
            ((test? a (car lat))((multirember-f test?) a (cdr lat)))
            (else (cons (car lat)
                        ((multirember-f test?) a (cdr lat))))))))

というような流れです。2のinsertも同じように。

2のinsertの方は、The Little Schemerでは以下のような解答となっています。

(define insert-g

  (lambda (seq)
    (lambda (new old l)
      (cond ((null? l) l)
            ((eq? old (car l))(seq new old (cdr l)))
            (else (cons (car l)
                        ((insert-g seq) new old (cdr l))))))))

参加者の方からも「冗長だよねー。」とか「きっともっとスマートに書けるはずだよねー、でもどう書いたらスマートだろう？」というような声がありました。

私もそう思います。ということで、考えて書いてみましたが、こんなんでどうでしょうか。srfi-1のfold-rightを使用しています・・・。

(define insert-g
  (lambda (set-f)
    (lambda (new old lat)
      (fold-right (lambda (e l)
                    (cond ((eq? old e)(set-f new old l))
                          (else (cons e l))))
                  '()
                  lat))))

ところｄ、foldって言語によってfold, reduce, inject, aggregateというように呼び名が違うらしいですね。

defineないけど小さなSchemeもどきで再帰動いたよー

攻殻機動隊の元ネタ

らしいという話を聞いていたので読んでみたいなーと思っていました。Ghost in the Machine といったところでしょうか。
中古は高いし、近隣の図書館の蔵書検索にもなかったので諦め気味です。

復刊ドットコムにリクエストが上がっていたので、とりあえず投票しました。

機械の中の幽霊

機械の中の幽霊 (ちくま学芸文庫)

posted with amazlet at 10.02.08

アーサーケストラー
筑摩書房
売り上げランキング: 387930

おすすめ度の平均:

GHOST IN THE SHELL

Ghost In The Machine

複雑系のキーワード：ホロン

Amazon.co.jp で詳細を見る

2010/02/04

defineないけど小さなSchemeもどきで再帰動いたよー

defineなし
数値演算はインクリメント（add1）とデクリメント（sub1）だけ

加算や乗算などはない

という小さな処理系。The Little Schemer で最後に作るもの。

階乗とか動くし、Y Combinatorもちゃんと動く。使えるのは以下のもの。

lambda, quote, cond
cons, car, cdr, atom?, zero?, add1, sub1, number?, null?, eq?

先日の

さっきの5の階乗

も↓のように動く。といっても加算も乗算もないので4章でやったように「インクリメントとデクリメントと再帰」でうまいこと「加算乗算を行なう無名関数」をでっち上げて・・・。

（valueはevalもどき）

(value '(((lambda (f)
            (f f))
          (lambda (f)
            (lambda (n)
              (cond ((zero? n) 1)
                    (else (((lambda (f)
                              (f f))
                            (lambda (f)
                              (lambda (n m)
                                (cond ((zero? m) 0)
                                      (else (((lambda (f)
                                                (f f))
                                              (lambda (f)
                                                (lambda (n m)
                                                  (cond ((zero? m) n)
                                                        (else ((lambda (n)(add1 n)) ((f f) n ((lambda (n)(sub1 n)) m))))))))
                                             n ((f f) n ((lambda (n)(sub1 n)) m))))))))
                           n ((f f) ((lambda (n)(sub1 n)) n)))))))) 5))

; -> 120

9章で出てくるY Combinatorも・・・

; y
(lambda (g)
((lambda (f)
     (f f))
   (lambda (f)
     (g (lambda (x)
          ((f f) x))))))

この通り。

(value '(((lambda (g)
            ((lambda (f)
               (f f))
             (lambda (f)
               (g (lambda (x)
                    ((f f) x))))))
          (lambda (f)
            (lambda (n)
              (cond ((zero? n) n)
                    (else (add1 (add1 (f (sub1 n))))))))) 5))

; -> 10

小さいSchemeもどき。

JSな人やErlangな人はこちら？

(define atom?
(lambda (x)
(and (not (pair? x))
(not (null? x)))))

(define add1
(lambda (n)
(+ n 1)))

(define sub1
(lambda (n)
(- n 1)))

(define first
(lambda (p)
(car p)))

(define second
(lambda (p)
(cadr p)))

(define third
(lambda (p)
(caddr p)))

(define build
(lambda (s1 s2)
(cons s1 (cons s2 '()))))

(define new-entry
(lambda (names values)
(build names values)))

(define extend-table
(lambda (entry table)
(cons entry table)))

(define text-of
(lambda (sexp)
(second sexp)))

(define table-of
(lambda (sexp)
(first sexp)))

(define formals-of
(lambda (sexp)
(second sexp)))

(define body-of
(lambda (sexp)
(third sexp)))

(define question-of
(lambda (sexp)
(first sexp)))

(define answer-of
(lambda (sexp)
(second sexp)))

(define cond-lines-of
(lambda (sexp)
(cdr sexp)))

(define function-of
(lambda (sexp)
(car sexp)))

(define arguments-of
(lambda (sexp)
(cdr sexp)))

(define primitive?
(lambda (l)
(eq? (first l) 'primitive)))

(define non-primitive?
(lambda (l)
(eq? (first l) 'non-primitive)))

(define else?
(lambda (x)
(eq? x 'else)))

(define lookup-in-entry
(lambda (name entry entry-f)
    (lookup-in-entry-help name
                          (first entry)
                          (second entry)
                          entry-f)))

(define lookup-in-entry-help
(lambda (name names values entry-f)
    (cond ((null? names)(entry-f name))
          ((eq? (car names) name)(car values))
          (else (lookup-in-entry-help name
                                      (cdr names)
                                      (cdr values)
                                      entry-f)))))

(define lookup-in-table
(lambda (name table table-f)
    (if (null? table)
        (table-f name)
        (lookup-in-entry name
                         (car table)
                         (lambda (name)
                           (lookup-in-table name
                                            (cdr table)
                                            table-f))))))

(define expression-to-action
(lambda (e)
    (if (atom? e)
        (atom-to-action e)
        (list-to-action e))))

(define atom-to-action
(lambda (e)
    (cond ((number? e) *const)
          ((eq? e #t) *const)
          ((eq? e #f) *const)
          ((eq? e 'cons) *const)
          ((eq? e 'car) *const)
          ((eq? e 'cdr) *const)
          ((eq? e 'null?) *const)
          ((eq? e 'eq?) *const)
          ((eq? e 'atom?) *const)
          ((eq? e 'zero?) *const)
          ((eq? e 'add1) *const)
          ((eq? e 'sub1) *const)
          ((eq? e 'number?) *const)
          (else *identifer))))

(define list-to-action
(lambda (e)
    (let ((op (car e)))
      (if (atom? op)
          (cond ((eq? op 'quote) *quote)
                ((eq? op 'lambda) *lambda)
                ((eq? op 'cond) *cond)
                (else *application))
          *application))))

(define value
(lambda (e)
(meaning e '())))

(define meaning
(lambda (e table)
((expression-to-action e) e table)))

(define initial-table
(lambda (name)
(car '())))

(define *const
(lambda (e table)
    (cond ((number? e) e)
          ((eq? e #t) #t)
          ((eq? e #f) #f)
          (else (build 'primitive e)))))

(define *quote
(lambda (e table)
(text-of e)))

(define *identifer
(lambda (e table)
(lookup-in-table e table initial-table)))

(define *lambda
(lambda (e table)
(build 'non-primitive
(cons table (cdr e)))))

(define evcon
(lambda (lines table)
    (let ((front (car lines)))
      (cond ((else? (question-of front))
             (meaning (answer-of front) table))
            ((meaning (question-of front) table)
             (meaning (answer-of front) table))
            (else (evcon (cdr lines) table))))))

(define *cond
(lambda (e table)
(evcon (cond-lines-of e) table)))

(define evlis
(lambda (args table)
    (if (null? args)
        '()
        (cons (meaning (car args) table)
              (evlis (cdr args) table)))))

(define *application
(lambda (e table)
(*apply (meaning (function-of e) table)
(evlis (arguments-of e) table))))

(define *apply
(lambda (fun vals)
(cond ((primitive? fun) (apply-primitive (second fun) vals))
((non-primitive? fun) (apply-closure (second fun) vals)))))

(define apply-primitive
(lambda (name vals)
    (let ((fst (first vals))
          (eqn? (lambda (q)
                  (eq? name q))))
      (cond ((eqn? 'car) (car fst))
            ((eqn? 'cdr) (cdr fst))
            ((eqn? 'null?) (null? fst))
            ((eqn? 'atom?) (*atom? fst))
            ((eqn? 'zero?) (zero? fst))
            ((eqn? 'add1) (add1 fst))
            ((eqn? 'sub1) (sub1 fst))
            ((eqn? 'number?) (number? fst))
            ((eqn? 'cons) (cons fst (second vals)))
            ((eqn? 'eq?) (eq? fst (second vals)))))))

(define *atom?
(lambda (x)
    (cond ((atom? x) #t)
          ((null? x) #f)
          ((eq? (car x) 'primitve) #t)
          ((eq? (car x) 'non-primitive) #f)
          (else #f))))

(define apply-closure
(lambda (closure vals)
    (meaning (body-of closure)
             (extend-table (new-entry (formals-of closure) vals)
                           (table-of closure)))))