The King's Museum

ソフトウェアエンジニアのブログ。

Scheme 手習い（７）

Scheme

第８章：究極の lambda

rember-f

(define (rember-f test? a l)
  (cond [(null? l) '()]
        [(test? (car l) a) (cdr l)]
        [else (cons (car l) (rember-f test? a (cdr l)))]))

リストから要素を削除する rember の派生版。 要素の一致を判定する関数を引数で与えることができる。

eq-c?

(define eq-c?
  (lambda (a)
    (lambda (x)
      (eq? a x))))

引数 a を与えると、その引数と eq? をとる関数を返す関数。 これはカリー化と呼ばれている。

rember-f

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

さきほどと同じ rember-f だが、「関数を適用すると関数が返ってくる」点が異なっている。 この関数を使うためには次のようにする。

((rember-f eq?) 1 '(1 2 3))

rember-f に eq? を与えると test? を eq? で束縛した a と l をとる関数返ってくる。 それに対し、1 と '(1 2 3) を引数として関数を呼び出す。

insertL-f/insertR-f

(define insertL-f
  (lambda (test?)
    (lambda (new old l)
      (cond [(null? l) '()]
            [(test? (car l) old) (cons new l)]
            [else (cons (car l) ((insertL-f test?) new old (cdr l)))]))))

(define insertR-f
  (lambda (test?)
    (lambda (new old l)
      (cond [(null? l) '()]
            [(test? (car l) old)
             (cons old (cons new (cdr l)))]
            [else (cons (car l) ((insertR-f test?) new old (cdr l)))]))))

リストの特定の要素の左か右に要素を挿入する関数の派生版。 比較関数を引数として与えられるようにしている。

insert-g

(define (seqL new old l)
  (cons new (cons old l)))
  
(define (seqR new old l)
  (cons old (cons new l)))

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

insertL と insertR を抽象化して、特定の要素のどちら側に要素を挿入するかを関数で与えられるようにしている。

(define insertL
  (insert-g seqL))

(define insertR
  (insert-g seqR))

insert-g に seqL と seqR を渡すと insertL と insertR を得ることができる。

なお、insertL と insertR は seqL と seqR を用意しなくても次のように定義できる。

(deifne insertL
  (insert-g
    (lambda (new old l)
      (cons new (cons old l)))))

(deifne insertR
  (insert-g
    (lambda (new old l)
      (cons old (cons new l)))))

また、要素を違う要素に置き換える subst も次のように定義できる。

(define subst
  (insert-g
    (lambda (new old l)
      (cons new l))))

さらに、なじみの深い rember も次のように定義できる。

(define rember
  (insert-g
    (lambda (new old l) l)))

第９の戒律

【第９の戒律】

新しき関数においては共通のパターンを抽象化すべし。

multirember-f

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

multirember の比較関数を引数で与えられるようにしたバージョン。

multirember-T

(define (multirember-T test? lat)
  (cond [(null? lat) '()]
        [(test? (car lat))
         (multirember-T test? (cdr lat))]
        [else (cons (car lat)
                    (multirember-T test? (cdr lat)))]))

multirember に特定の値と比較する比較関数を与えられるようにしたバージョン。 次のような関数を定義し、multirember-T に与える。

(define (eq?-tuna k)
  (eq? 'tuna k))

(multirember-T eq?-tuna '(tuna shrimp salad))

multirember&co

(define (multirember&co a lat col)
  (cond [(null? lat) (col '() '())]
        [(eq? (car lat) a)
         (multirember&co a (cdr lat)
           (lambda (newlat seen)
             (col newlat (cons a seen))))]
        [else
         (mutltirember&co a (cdr lat)
           (lambda (newlat seen)
             (col (cons (car lat) newlat) seen)))]))

multirember を継続渡しスタイル (continuation passing style) と呼ばれるやり方に変更したバージョン。

ちなみにこの例では継続を使って、さらに再帰しているので非常に分かりづらい。 継続を説明せずにいきなりこの例を出されるのはけっこう辛いものがある。

multiinsertLR

(define (multiinsertLR oldL oldR new lat)
  (cond [(null? lat) '()]
        [(eq? oldL (car lat))
         (cons new (cons oldL
                    (multiinsertLR oldL oldR new (cdr lat))))]
        [(eq? oldR (car lat))
         (cons oldR (cons new
                    (multiinsertLR oldL oldR new (cdr lat))))]
        [else (cons (car lat)
                    (multiinsertLR oldL oldR new (cdr lat)))]))

oldL の要素の左に new　を、oldR の要素の右に new を挿入する関数。 これ自体はそれほど難しくない。

multiinsertLR&co

(define (multiinsertLR&co oldL oldR new lat col)
  (cond [(null? lat) (col 0 0 '())]
        [(eq? oldL (car lat))
         (multiinsertLR&co oldL oldR new (cdr lat)
           (lambda (l r newlat)
             (col (+ 1 l) r (cons new (cons oldL newlat)))))]
        [(eq? oldR (car lat))
         (multiinsertLR&co oldL oldR new (cdr lat)
           (lambda (l r newlat)
             (col l (+ r 1) (cons oldR (cons new newlat)))))]
        [else
         (multiinsertLR&co oldL oldR new (cdr lat)
           (lambda (l r newlat)
             (col l r (cons (car l) newlat))))]))

multiinsertLR を継続渡しスタイルにしたバージョン。 この例はぎりぎり理解できている（気がする）。

外側からどんどん関数を適用（ひも解いていく）するイメージかな…。

evens-only*

(define (evens-only* lat)
  (cond [(null? lat) '()]
        [(atom? (car lat))
         (cond [(even? (car lat)) (cons (car lat) (evens-only (cdr lat)))]
               [else (evens-only (cdr lat))])]
        [else (cons (evens-only (car lat)) (evens-only (cdr lat)))]))

入れ子になったリストから奇数を除去する関数。 入れ子を走査するために、(car lat) が atom? かどうかで分岐しているのがポイント。

evens-only*&co

(define (evens-only*&co lat col)
  (cond [(null? lat) (col '() 1 0)]
        [(atom? (car lat))
         (cond [(even? (car lat))
                (evens-only*&co (cdr lat)
                  (lambda (newlat p s)
                    (col (cons (car lat) newlat) (* p (car lat)) s)))]                    
               [else
                (evens-only*&co (cdr lat)
                  (lambda (newlat p s)
                    (col newlat p (+ (car lat) s))))])]
        [else
         (evens-only*&co (car lat)
           (lambda (newlat p s)
             (evens-only*&co (cdr lat)
               (lambda (dnewlat dp ds)
                 (col (cons newlat dnewlat) (* dp p) (+ ds s))))))]))

evens-only* を継続渡しスタイルにしたバージョン。 ここで自分の理解能力の限界を超えた。

(evens-only*&co (car lat)
  (lambda (newlat p s)
    (evens-only*&co (cdr lat)
      (lambda (dnewlat dp ds)
        (col (cons newlat dnewlat) (* dp p) (+ ds s))))))

この部分がなぜ、こうなるのかまだきちんと理解できていない。

本には、

ひえー。頭がこんがらがりそうですね。

と書かれていたが、ほんとにその通り。

自分の理解のために次の章に進む前に継続について一つの記事を書こうかな。

(c) The King's Museum