blog.PanicBlanket.com

multiinsertLR

関数 multiinsertLR は lat の中の oldL の左と oldR の右に new を挿入する。

(define multiinsertLR
  (lambda (new oldL oldR lat)
    (cond
      ((null? lat) (quote ()))
      ((eq? (car lat) oldL)
        (cons new (cons oldL (multiinsertLR new oldL oldR (cdr lat)))))
      ((eq? (car lat) oldR)
        (cons oldR (cons new (multiinsertLR new oldL oldR (cdr lat)))))
      (else
        (cons (car lat) (multiinsertLR new oldL oldR (cdr lat)))))))

(print (multiinsertLR 'salty 'fish 'chips '(chips and fish or fish and chips)))

^o^ > gosh multiinsertLR.scm
(chips salty and salty fish or salty fish and chips salty)

うん、うまくいってる。

multiinsertLR&co

さて、ここからが本題。multirember に対応する multirember&co のように、multiinsertLR に対応する multiinsertLR&co を書け、ときた。ようするに、引数を1つ多くとり、それは収集子（関数）だってことだ。で、multiinsertLR&co が実行されると、新たなラット、左挿入の回数、右挿入の回数を引数として収集子 col を呼び出す。
よし、挑戦してみよう。

(use mymodule)

(define multiinsertLR&co
  (lambda (new oldL oldR lat col)
    (cond
      ((null? lat) (col (quote ()) 0 0))
      ((eq? (car lat) oldL)
        (multiinsertLR&co new oldL oldR (cdr lat)
          (lambda (newlat l r) (col (cons new (cons oldL newlat)) (add1 l) r))))
      ((eq? (car lat) oldR)
        (multiinsertLR&co new oldL oldR (cdr lat)
          (lambda (newlat l r) (col (cons oldR (cons new newlat)) l (add1 r)))))
      (else
        (multiinsertLR&co new oldL oldR (cdr lat)
          (lambda (newlat l r) (col (cons (car lat) newlat) l r)))))))

(define result
  (lambda (lat l r)
    (list lat l r)))

(print (multiinsertLR&co 'salty 'fish 'chips '(chips and fish or fish and chips) result))

今回、col の具体的な実装は出てこないので、収集した結果（新しいラット、左挿入の回数、右挿入の回数）をリストにして返す result を収集子にしてみた。

^o^ > gosh -I. multiinsertLR_and_co.scm
((chips salty and salty fish or salty fish and chips salty) 2 2)

うまくいった！

こんな関数が出てきた。

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

これはかなり複雑だ。
基本的には multirember と同じような形をしているけど、引数がひとつ多い。 a はアトム、lat はラット、で、col は何かの関数らしい。
それから、(eq? (car lat) a) のときも else のときも (cdr lat) で再帰している。しかもそれぞれ新しい関数を作っている。

じっくりいこう。

col の簡単な例が出てきた。

(define a-friend
  (lambda (x y)
    (null? y)))

2つの引数をとり、1つ目は単に無視して2つ目が null? かどうかを返している。

で、この関数を使ってまずは簡単な例、(multirember&co 'tuna '() a-friend) の値を求めてみよう。この場合、lat が空リストなので、cond の最初の条件に当てはまる。ということはその値は (col (quote ()) (quote ())) で、いま col は a-friend なので値は #t になる。

次は、もうちょっと難しい例、(multirember&co 'tuna '(tuna) a-friend) の値を求めてみよう。今度は、(eq? (car lat) a) （ここで a は tuna、lat は (tuna)）なので、cond の2番目の値になる。そして (cdr lat) と新しい関数 (lambda (newlat seen) (col newlat (cons (car lat) seen))) に対して再帰している。この関数は multirember&co の引数 col に当たるもので、col とは collector （収集子）の短縮形だそうだ（収集子は「continuation（継続）」とも呼ばれる）。
この新しい関数（収集子）に名前をつけてやったほうがわかり易い。new-friend としよう。このとき col は a-friend、(car lat) は tuna なので、new-friend は次のようになる。

(define new-friend
  (lambda (newlat seen)
    (a-frined newlat (cons 'tuna seen))))

この関数を使って、multirember&co の再帰部分を書くと、(multirember&co 'tuna '() new-friend) となる。
そうすると今度は (null? lat) （ここで lat は ‘()）なので、値は (new-friend (quote ()) (quote ())) となり、new-friend の定義より (a-friend (quote ()) (cons 'tuna (quote ())))、つまり #f だ（2番目の引数が空リストじゃないから）。

さらに難しい例、(multirember&co 'tuna '(and tuna) a-friend) の値を求めてみよう。今度は、cond の3番目の条件に当てはまり、また別の収集子で再帰する。この収集子の名前を latest-friend とすれば次のようになる。

(define latest-friend
  (lambda (newlat seen)
    (a-friend (cons 'and newlat) seen))))

すると、再帰は (multirember&co 'tuna '(tuna) latest-friend) となり、cond の2番目の条件でさらに (multirember&co 'tuna '() (lambda (newlat seen) (latest-friend newlat (cons 'tuna seen)))) で再帰する。
最後は cond の最初の条件の値 ((lambda (newlat seen) (latest-friend newlat (cons 'tuna seen))) (quote ()) (quote ())) に行き当たる。
さあ、今度は逆にさかのぼろう。最後の関数適用の値は (latest-friend (quote ()) ‘(tuna)) だ。さらにさかのぼると (a-friend ‘(and) ‘(tuna)) となり、最終的な値は #f になる。

結局、(multirember&co a lat col) がどんな関数かというと、lat をすべて検索して、a と eq? であるアトムを最初のリスト l1 に、eq? でないアトムを2番目のリスト l2 に収集子、最後に (col l1 l2) の値を返す関数、ということができる。

試してみよう。

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

(define a-friend
  (lambda (x y)
    (null? y)))

(print (multirember&co 'tuna '() a-friend))
(print (multirember&co 'tuna '(tuna) a-friend))
(print (multirember&co 'tuna '(and tuna) a-friend))

^o^ > gosh multirember_and_co.scm
#t
#f
#f

OKのようだ。

最後に、次の関数 last-friend を col とした場合を求めてみよう。

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

(define last-friend
  (lambda (x y)
    (length x)))

(print (multirember&co 'tuna '(strawberries tuna and swordfish) last-friend))

^o^ > gosh multirember_and_co2.scm
3

last-friend は tuna 以外のアトムを集めたリストの長さを求めている。だから答は3になるわけだ。

第10の戒律
同時に2つ以上の値を集める際には関数を作るべし。

multirember-f

multiremver の定義は次のとおりだった。

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

今度は multirember-f を書いてください、ときた。簡単だ。test? を引数にとって、上の定義の中の eq? を test? に、multirember を (multirember test?) に置き換えたものを返してやればいい。

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

(print ((multirember-f eq?) 'tuna '(shrimp salad tuna salad and tuna)))

^o^ > gosh multirember-f.scm
(shrimp salad salad and)

multiremberT

ここで eq?-c が再登場する。この関数はアトム a を引数にとって「アトム x を引数にとって a 比較する関数」を返す関数だった。x を tuna と比較する関数 eq?-tuna は次のように書ける。

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

さて、今度は、この eq?-tuna のような関数とラットを引数にとって multirember と同じように動作する multiremberT を書け、ときた。大丈夫、たぶん書けるだろう。

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

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

(define multiremberT
  (lambda (test? lat)
    (cond
      ((null? lat) (quote ()))
      ((test? (car lat)) (multiremberT test? (cdr lat)))
      (else (cons (car lat) (multiremberT test? (cdr lat)))))))

(print (multiremberT eq?-tuna '(shrimp salad tuna salad and tuna)))

実行結果：

^o^ > gosh multiremberT.scm
(shrimp salad salad and)

よかった、OKのようだ。

6章に出てきた value が再登場だ。value の定義は次のとおりだった（補助関数の定義は省略している）。

(define value
  (lambda (nexp)
    (cond
      ((atom? nexp) nexp)
      ((eq? (operator nexp) (quote e+))
        (o+ (value (1st-sub-exp nexp)) (value (2nd-sub-exp nexp))))
      ((eq? (operator nexp) (quote e*))
        (o* (value (1st-sub-exp nexp)) (value (2nd-sub-exp nexp))))
      (else
        (o^ (value (1st-sub-exp nexp)) (value (2nd-sub-exp nexp)))))))

4つある cond の質問と値のうち、最初のを別にすれば3つともよく似ている。違うのは演算子とそれに対応する関数だけだ。そこで、演算子（演算子はアトムであることに注意）から関数に変換する関数を書いてやれば、上の定義を簡単化することができる。
変換する関数 atom-to-function はこうだ。

(define atom-to-function
  (lambda (o)
    (cond
      ((eq? o (quote e+)) o+)
      ((eq? o (quote e*)) o*)
      (else o^))))

これを使って、簡単化した value はこうなる。補助関数も含めて全体を示す。

(use mymodule)

(define 1st-sub-exp
  (lambda (aexp)
    (car (cdr aexp))))

(define 2nd-sub-exp
  (lambda (aexp)
    (car (cdr (cdr aexp)))))

(define operator
  (lambda (aexp)
    (car aexp)))

(define atom-to-function
  (lambda (o)
    (cond
      ((eq? o (quote e+)) o+)
      ((eq? o (quote e*)) o*)
      (else o^))))

(define value
  (lambda (nexp)
    (cond
      ((atom? nexp) nexp)
      (else
        ((atom-to-function (operator nexp)) (value (1st-sub-exp nexp)) (value (2nd-sub-exp nexp)))))))

(print (value '(e+ 3 8)))
(print (value '(e+ (e* 3 6) (e^ 8 2))))

実行結果：

^o^ > gosh -I. value4.scm
11
82

うまくいった！

subst

リストの中の old を new に置き換える subst は次のような定義だった。

(define subst
  (lambda (new old l)
    (cond
      ((null? l) (quote ()))
      ((eq? (car l) old) (cons new (cdr l)))
      (else (cons (car l) (subst new old (cdr l)))))))

これもやっぱり、前回の insertL や insertR とよく似ている。違うのは cond の2行目、((eq? …) の行だけだ。というわけで、subst のための関数 seqS を作り、insert-g を使って subst を定義せよ、と。
こんなんでどうだ。（ちなみに insert-g の定義は本のとおり test? を引数にとらずに eq? を使うようにした）

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

(define seqS
  (lambda (new old l)
    (cons new l)))

(define subst (insert-g seqS))

(print (subst 'topping 'fudge '(ice cream with fudge for dessert)))

^o^ > gosh subst2.scm
(ice cream with topping for dessert)

OKだ。

yyy

今度は次のような関数 yyy が出てきた。

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

(define seqrem
  (lambda (new old l)
    l))

(define yyy
  (lambda (a l)
    ((insert-g seqrem) #f a l)))

(print (yyy 'sausage '(pizza with sausage and bacon)))

関数 yyy の定義で insert-g に渡している関数 seqrem は、new や old を cons せずに l だけを返している。ということは、(eq? (car l)) だったとき、new も old も cons されないわけで、つまり yyy は old を削除する関数 rember だってことだ。

^o^ > gosh yyy.scm
(pizza with and bacon)

本では、「#f はどんな役割を果たしていますか。」と書いてあるけど、#f は seqrem の引数 new に当たるので、関数の中では何の役目も果たしていない。実際、#f を #t やほかのアトムに変えても yyy の動作は変わらない。ただの数合わせのためだけにあるわけだ。

前回と今回のまとめ

前回と今回で insertL、insertR、subst、rember という4つの関数が、insert-g とそれぞれの補助関数で定義できることを見てきた。全体的によく似た関数は、同じ部分は共通の関数を使い、違う部分だけをそれぞれの補助関数にして定義できる。これが抽象化というものの力だそうだ。

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

insertL-f と insertR-f

rember を rember-f に変形したように、insertL を insertL-f に変形してください、ときた。といってもすぐに答が書いてあるので、ここは逆らわずに写経。

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

同様に、insertR を insertR-f に。

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

見比べればわかるように、insertL-f と insertR-f はよく似ている。実際、関数名を別にすれば違うのは6行目の new を old を cons する順番だけだ。
というわけで、次の課題はこの部分を関数として渡してやれるようにすることだ。

insert-g

まずは、上の6行目の部分だけを行う関数、seqL と seqR を書こう。といってもほとんど自明だ。

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

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

さあ、これで insert-g が書ける。全体を示そう。

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

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

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

(define insertL (insert-g eq? seqL))

(define insertR (insert-g eq? seqR))

(print (insertL 'topping 'fudge '(ice cream with fudge for dessert)))
(print (insertR 'jalapeno 'and '(tacos tamales and salsa)))

実行結果：

^o^ > gosh insert-g.scm
(ice cream with topping fudge for dessert)
(tacos tamales and jalapeno salsa)

うまくいった！
と思って答を見たら、こんな定義になってるじゃないか。

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

test? はどこへいったんだよ！
まあいい、このままいこう。最後に、seqL を使わずに insertL を定義してください、ときた。前のエントリで書いたように、lambda で作った関数には必ずしも名前をつけなくてもかまわない。ということは、seqL という関数名じゃなくてその定義を渡してやればいいわけだ。

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

(define insertL
  (insert-g eq?
    (lambda (new old l)
      (cons new (cons old l)))))

(print (insertL 'topping 'fudge '(ice cream with fudge for dessert)))

^o^ > gosh insert-g2.scm
(ice cream with topping fudge for dessert)

OKのようだ。よかった。

関数を返す関数

前回のエントリでは関数を引数にとる関数が出てきたけど、今度は関数を返す関数（これも高階関数だ）が出てきた。

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

この関数 eq?-c は a を引数にとり、「x を引数にとって a と比較する関数」を返す。
「これは『カリー化』（Curry-ing）と呼ばれています。」って、カリー化の説明これだけ？
カリー化とは、本来複数の引数を取る関数を引数の一部だけとって「残りの引数を取る関数」を返す関数に変更、というか変換すること、だと理解している。そう間違ってはいないはず。この例の場合では2引数の関数 eq? をカリー化した関数が eq?-c ってわけだ。

返ってくるのが関数だから、名前をつけてやれば普通の関数として使える。

gosh> (define eq?-c
  (lambda (a)
    (lambda (x)
      (eq? x a))))
eq?-c
gosh> (define eq?-salad (eq?-c 'salad))
eq?-salad
gosh> (eq?-salad 'salad)
#t
gosh> (eq?-salad 'tuna)
#f

とはいえ、必要がなければ名前をつけてやることもない。こんなふうにも書ける。

gosh> ((eq?-c 'salad) 'salad)
#t

ふたたび rember-f

で、今度は、rember-f を比較関数 test? を引数にとって「a と l を引数にとる関数」を返す関数に書き直せ、ときた。うん、たぶん書けるだろう。

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

(print ((rember-f eq?) 'tuna '(shrimp salad and tuna salad)))

^o^ > gosh rember-f2.scm
(shrimp salad and salad)

うまくいった！

今日から8章だ。
関数を引数にとる関数が出てきた（高階関数だ！）。rember-f は rember と同様に、リストからメンバーを削除するけど、削除するメンバーを探す（比較する）関数も引数として受け取る。たとえばリストが数のリストなら比較のために o= を、S式のリストなら equal? を引数として受け取るわけだ。
ちょっと難しいけど、うん、まあこのくらいなら書けそうだ。

(use mymodule)

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

(print (rember-f o= 5 '(6 2 5 3)))
(print (rember-f eq? 'jelly '(jelly beans are good)))
(print (rember-f equal? '(pop corn) '(lemonade (pop corn) and (cake))))

実行結果：

^o^ > gosh -I. rember-f.scm
(6 2 3)
(beans are good)
(lemonade and (cake))

うまくいった。

関数 fullfunn? （または one-to-one?）は、ファンが全単射、つまり各ペアの第2要素を集めたリストが集合になっているかどうかを判定する。
書いてみよう。

(use mymodule)

(define seconds
  (lambda (rel)
    (cond
      ((null? rel) (quote ()))
      (else (cons (second (car rel)) (seconds (cdr rel)))))))

(define fullfun?
  (lambda (fun)
    (set? (seconds fun))))

(print (fullfun? '((8 3) (4 8) (7 6) (6 2) (3 4))))
(print (fullfun? '((grape raisin) (plum prune) (stewed prune))))
(print (fullfun? '((grape raisin) (plum prune) (stewed grape))))

ここで、seconds という補助関数を作っている。seconds は各ペアの第2要素を集めたリストを作る。それが集合（セット）になっているかどうかを調べているわけだ。

^o^ > gosh -I. fullfun.scm
#t
#f
#t

うまくいったようだ。

ところで、one-to-one? は fullfun? の別名だ。全単射ということは一対一対応だということだからだろう。ここで、one-to-one? の別の定義は思いつけるかという質問が出てきた。ペアの第2要素が集合になっているなら、第1要素と第2要素を入れ替えた (revrel fun) はファンになっているはず。これを使うと次のようになる。

(use mymodule)

(define fun?
  (lambda (rel)
    (set? (firsts rel))))

(define revpair
  (lambda (pair)
    (build (second pair) (first pair))))

(define revrel
  (lambda (rel)
    (cond
      ((null? rel) (quote ()))
      (else (cons (revpair (car rel))
        (revrel (cdr rel)))))))

(define one-to-one?
  (lambda (fun)
    (fun? (revrel fun))))

(print (one-to-one? '((8 3) (4 8) (7 6) (6 2) (3 4))))
(print (one-to-one? '((grape raisin) (plum prune) (stewed prune))))
(print (one-to-one? '((grape raisin) (plum prune) (stewed grape))))

^o^ > gosh -I. one-to-one.scm
#t
#f
#t

これで7章も終わり。

関数 revrel は、レルの各ペアの第1要素と第2要素を入れ替える関数。rev は reverse の略かな。
書いてみよう。

(use mymodule)

(define revrel
  (lambda (rel)
    (cond
      ((null? rel) (quote ()))
      (else (cons (build (second (car rel)) (first (car rel)))
        (revrel (cdr rel)))))))

(print (revrel '((8 a) (pumpkin pie) (got sick))))

前々回のエントリで作った、first、second、build を使っている。

実行：

^o^ > gosh -I. revrel.scm
((a 8) (pie pumpkin) (sick got))

ここで、ペアの2つの要素を交換する revpair 関数があったとして revrel を書くとどうなるか。こうなる。

(use mymodule)

(define revpair
  (lambda (pair)
    (build (second pair) (first pair))))

(define revrel
  (lambda (rel)
    (cond
      ((null? rel) (quote ()))
      (else (cons (revpair (car rel))
        (revrel (cdr rel)))))))

(print (revrel '((8 a) (pumpkin pie) (got sick))))

実行：

^o^ > gosh -I. revrel2.scm
((a 8) (pie pumpkin) (sick got))

当たり前だけど、書き直す前と同じ結果になった。