●問題26
リスト ls を木とみなして、x と等しい要素 (葉) を探す関数 member-tree x ls を定義してください。
gosh> (member-tree 'd '(a (b (c (d . e) f) g) h)) #t gosh> (member-tree 'e '(a (b (c (d . e) f) g) h)) #t gosh> (member-tree 'x '(a (b (c (d . e) f) g) h)) #f
●問題27
リストを木とみなして、要素 (葉) を数える関数 count-leaf を定義してください。
gosh> (count-leaf '(a (b (c (d . e) f) g) h)) 8
●問題28
リスト ls を木とみなして、x と等しい要素を y に置換する関数 subst x y ls を定義してください。
gosh> (subst 'a 'x '(a (b (a (c . a) d) a) e)) (x (b (x (c . x) d) x) e)
●問題29
リスト ls から n 個の要素を選ぶ順列を求める関数 permutation n ls を定義してください。なお、生成した順列はリストに格納して返すものとします。
gosh> (permutation 3 '(a b c)) ((a b c) (a c b) (b a c) (b c a) (c a b) (c b a))
●問題30
リスト ls から重複を許して n 個の要素を選ぶ順列を求める関数 repeat-perm n ls を定義してください。なお、生成した順列はリストに格納して返すものとします。
gosh> (repeat-perm 3 '(a b c)) ((a a a) (a a b) (a a c) (a b a) (a b b) (a b c) (a c a) (a c b) (a c c) (b a a) (b a b) (b a c) (b b a) (b b b) (b b c) (b c a) (b c b) (b c c) (c a a) (c a b) (c a c) (c b a) (c b b) (c b c) (c c a) (c c b) (c c c))
●問題31
n 個の中から r 個を選ぶ組み合わせの数 nＣr を求める関数 comb-num n r を定義してください。
gosh> (comb-num 5 3) 10 gosh> (comb-num 10 5) 252
●問題32
リスト ls から n 個の要素を選ぶ組み合わせを求める関数 combination n ls を定義してください。なお、生成した組み合わせはリストに格納して返すものとします。
gosh> (display (combination 3 '(a b c d e))) ((a b c) (a b d) (a b e) (a c d) (a c e) (a d e) (b c d) (b c e) (b d e) (c d e))#<undef>
●問題33
リスト ls から重複を許して n 個の要素を選ぶ組み合わせを求める関数 repeat-comb n ls を定義してください。
gosh> (repeat-comb 3 '(a b c d)) ((a a a) (a a b) (a a c) (a a d) (a b b) (a b c) (a b d) (a c c) (a c d) (a d d) (b b b) (b b c) (b b d) (b c c) (b c d) (b d d) (c c c) (c c d) (c d d) (d d d))
●問題34
リスト ls を n 番目の要素で二分割する関数 split-nth ls n を定義してください。なお、分割したリストは多値で返すものとします。
gosh> (split-nth '(a b c d e f) 3) (a b c) (d e f) gosh> (split-nth '(a b c d e f) 4) (a b c d) (e f)
●問題35
リストを奇数番目の要素と偶数番目の要素に分ける関数 partition を定義してください。なお、分割したリストは多値で返すものとします。
gosh> (partition '(a b c d e f g)) (a c e g) (b d f)
●問題36
x と等しい要素の位置でリスト ls を二分割する関数 split-find x ls を定義してください。なお、分割したリストは多値で返すものとします。
gosh> (split-find 'c '(a b c d e f)) (a b) (c d e f)
●問題37
リスト ls を x よりも大きい要素と x 以下の要素に分ける関数 split-ge x ls を定義してください。なお、分割したリストは多値で返すものとします。
gosh> (split-ge 5 '(4 6 3 5 7 8 2 9 1)) (4 3 2 1) (6 5 7 8 9)
●問題38
リストの中で連続した等しい記号を部分リストにまとめる関数 pack を定義してください。
gosh> (pack '(a a a b b c c c c d e e e e e)) ((a a a) (b b) (c c c c) (d) (e e e e e))
●問題39
整列済みの整数を表すリストで、連続している部分列を (start . end) に置き換える関数 pack-num-list を定義してください。start は部分列の始点、end は部分列の終点を表します。
gosh> (pack-num-list '(1 2 3 5 7 8 10)) ((1 . 3) 5 (7 . 8) 10)
なお、この問題は下記サイトを参考にさせていただきました。関係各位に感謝いたします。
●問題40
問題 39 の逆変換を行う関数 expand-num-list を定義してください。
gosh> (expand-num-list '((1 . 3) 5 (7 . 8) 10)) (1 2 3 5 7 8 10)
●問題41
連続している同じ記号を (code . num) に変換する関数 encode を定義してください。code は記号、num は個数を表します。このような変換を「ランレングス符号化」といいます。
gosh> (encode '(a a a b b c d d d d d e)) ((a . 3) (b . 2) (c . 1) (d . 5) (e . 1))
●問題42
問題 41 の逆変換を行う関数 decode を定義してください。
gosh> (decode '((a . 3) (b . 2) (c . 1) (d . 5) (e . 1))) (a a a b b c d d d d d e)
●問題43
リストの要素に述語 pred を適用し、一つでも真を返す要素があれば真を返す関数 any? と、一つでも偽を返す要素があれば偽を返す (全てが真の場合に真を返す) 関数 every? を定義してください。
gosh> (any? even? '(1 3 5 7 9)) #f gosh> (any? even? '(1 3 4 5 7 9)) #t gosh> (every? even? '(2 4 6 8 10)) #t gosh> (every? even? '(2 4 6 5 8 10)) #f
●問題44
map f xs はリスト xs の要素に関数 f を適用します。関数 maplist は関数 f にリストそのものを渡します。ただし、繰り返すたびにリストの先頭要素は取り除かれていきます。関数 maplist を定義してください。
gosh> (display (maplist (lambda (x) x) '(a b c d e))) ((a b c d e) (b c d e) (c d e) (d e) (e))#<undef> gosh> (maplist (lambda (x) (fold + 0 x)) '(1 2 3 4 5)) (15 14 12 9 5)
●問題45
リスト操作を一般化した関数 for-each-list fn comb term xs を定義してください。ここで、fn はリストの要素に適用する関数、comb は関数の返り値を結合する関数、term は終端の値、xs がリストです。
gosh> (for-each-list (lambda (x) x) + 0 '(1 2 3 4 5)) 15 gosh> (for-each-list (lambda (x) (* x x)) + 0 '(1 2 3 4 5)) 55 gosh> (for-each-list (lambda (x) x) append '() '((a b) (c d e) () (f g))) (a b c d e f g)
●問題46
関数 for-each-list を使ってマッピング、フィルター、畳み込みを行う関数を定義してください。
●問題47
パズル「小町分数」を解くプログラムを作ってください。
下図の A から I の場所に 1 から 9 までの数字をひとつずつ配置します。3 つの分数を足すと 1 / N になる配置を求めてください。
A D G 1
--- + --- + --- = ---
B C E F H I N
ex) 3 / 27 + 6 / 54 + 9 / 81 = 1 / 3
3 / 54 + 6 / 72 + 9 / 81 = 1 / 4
図 : 小町分数
このパズルの元ネタは N = 1 の場合で、参考文献 [1] に掲載されています。
[1] 芦ヶ原伸之,『超々難問数理パズル 解けるものなら解いてごらん』, 講談社, 2002
●問題48
3 行 3 列の魔方陣を解くプログラムを作ってください。
図 : 魔方陣
上図の A から I の場所に 1 から 9 までの数字をひとつずつ配置します。縦横斜めの合計が等しくなるように数字を配置してください。
●問題49
計算式の数字を文字や記号に置き換えて、それを元の数字に戻すパズルを「覆面算」といいます。異なる文字は異なる数字を表し、同じ文字は同じ数字を表します。覆面算 WRONG * M = RIGHT を解くプログラムを作ってください。なお、今回は使用する数字を 1 から 9 までとします。
W R O N G * M ------------ R I G H T 図 : 小町覆面算
●問題50
自然数 n 以下の素数をすべて求める関数 sieve を作ってください。
gosh> (sieve 100) (2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97)
●解答26
リスト : 木の探索
(define (member-tree x ls)
(define (iter ls cont)
(cond ((pair? ls)
(iter (car ls) cont)
(iter (cdr ls) cont))
((eqv? x ls) (cont #t))
(else #f)))
(call/cc
(lambda (cont) (iter ls cont))))
; 別解 (CPS)
(define (member-tree-cps x ls)
(define (iter ls cont)
(cond ((pair? ls)
(iter (car ls)
(lambda (y) (iter (cdr ls)
(lambda (z) (cont z))))))
((eqv? x ls) #t)
(else (cont #f))))
(iter ls (lambda (x) x)))
探索は局所関数 iter で行います。探索の途中で値を返すため脱出用の継続を引数 cont に渡します。リストを二分木と考えると、リストの先頭要素が左部分木、残りのリストが右部分木に相当します。左右の部分木に対して iter を再帰呼び出しすればいいわけです。今回は葉を探索するので、x と等しい要素が見つけたならば、継続 cont を呼び出して #t を返します。そうでなければ、else 節で #f を返します。
別解は継続渡しスタイル (Continuation Passing Style : CPS) で書き直したものです。
●解答27
リスト : 葉の個数を求める
(define (count-leaf ls)
(cond ((pair? ls)
(+ (count-leaf (car ls))
(count-leaf (cdr ls))))
((null? ls) 0)
(else 1)))
; 別解 (CPS)
(define (count-leaf-cps ls)
(define (iter ls cont)
(cond ((pair? ls)
(iter (car ls)
(lambda (a) (iter (cdr ls)
(lambda (b) (cont (+ a b)))))))
((null? ls) (cont 0))
(else (cont 1))))
(iter ls (lambda (x) x)))
count-leaf も簡単です。ls がコンスセルならば左右の部分木にたいして count-leaf を再帰呼び出しし、その結果を足し算して返します。ls が空リストならば 0 を返します。そうでなければ、ls は葉なので 1 を返します。別解は継続渡しスタイル (Continuation Passing Style : CPS) で書き直したものです。
●解答28
リスト : 木の置換
(define (subst x y ls)
(cond ((pair? ls)
(cons (subst x y (car ls))
(subst x y (cdr ls))))
((eqv? x ls) y)
(else ls)))
; 別解 (CPS)
(define (subst-cps x y ls)
(define (iter ls cont)
(cond ((pair? ls)
(iter (car ls)
(lambda (a) (iter (cdr ls)
(lambda (b) (cont (cons a b)))))))
((eqv? x ls) (cont y))
(else (cont ls))))
(iter ls (lambda (x) x)))
subst も簡単です。ls がコンスセルならば左右の部分木にたいして subst を再帰呼び出しし、その結果を cons で連結して返します。ls が x と等しい場合は y を返します。それ以外の場合は ls を返します。別解は継続渡しスタイル (Continuation Passing Style : CPS) で書き直したものです。
●解答29
リスト : 順列の生成
; x と等しい要素を削除する
(define (remove x ls)
(cond ((null? ls) '())
((eqv? x (car ls))
(remove x (cdr ls)))
(else
(cons (car ls) (remove x (cdr ls))))))
; map の結果を平坦化する
(define (flatmap func ls)
(apply append (map func ls)))
; 順列をリストに格納して返す
(define (permutation n ls)
(if (zero? n)
(list '())
(flatmap
(lambda (x)
(map (lambda (y) (cons x y))
(permutation (- n 1) (remove x ls))))
ls)))
関数 permutation は引数のリスト ls から n 個を選ぶ順列を生成し、それをリストに格納して返します。n が 0 のときが再帰の停止条件で、空リストを格納したリストを返します。このリストに対して要素を追加します。この処理は map を二重に使うと簡単に実現できます。このとき、リストを平坦化します。これを関数 flatmap で行っています。
あとはラムダ式の中で permutation を再帰呼び出しをして、n - 1 個を選ぶ順列を生成します。そして、その返り値にリスト ls の要素 x を追加すれば、n 個を選ぶ順列を生成することができます。
●解答30
リスト : 重複順列
(define (repeat-perm n ls)
(if (zero? n)
(list '())
(flatmap
(lambda (x)
(map (lambda (y) (cons x y))
(repeat-perm (- n 1) ls)))
ls)))
重複順列も簡単です。選んだ要素を取り除く必要がないので、repeat-perm を再帰呼び出しするとき、リスト ls をそのまま渡すだけです。
●解答31
組み合わせの数を nＣr と表記します。nＣr を求めるには、次の公式を使えば簡単です。
nＣr = n * (n - 1) * (n - 2) * ... * (n - r + 1) / (1 * 2 * 3 * ... * r)
皆さんお馴染みの公式ですね。この公式をそのままプログラムすることもできますが、次の式を使うともっと簡単にプログラムできます。
nＣ0 = nＣn = 1 nＣr = nＣr-1 * (n - r + 1) / r
この式は nＣr と nＣr-1 の関係を表しています。あとは再帰定義を使って簡単にプログラムできます。
リスト : 組み合わせの数
(define (comb-num n r)
(if (or (= n r) (= r 0))
1
(/ (* (comb-num n (- r 1)) (+ (- n r) 1)) r)))
●解答32
組み合わせの生成は、次に示す組み合わせの公式と同じ考え方でプログラムすることができます。
nＣ0 = nＣn = 1 nＣr = n-1Ｃr-1 + n-1Ｃr
プログラムは次のようになります。
リスト : 組み合わせの生成
(define (combination n ls)
(cond ((= n 0) (list '()))
((= n (length ls)) (list ls))
(else
(append
(map (lambda (x) (cons (car ls) x))
(combination (- n 1) (cdr ls)))
(combination n (cdr ls))))))
最初の節は個数 n が 0 の場合です。選択する要素がないので空リストを格納したリストを返します。次の節で、n と ls の要素数が同じ場合は、その要素を全て選択するので ls をリストに格納して返します。
そうでなければ、先頭要素 (car ls) を選びます。残りのリスト (cdr ls) から n - 1 個を選ぶ組み合わせを生成して、その先頭に (car ls) を追加します。あとは、(cdr ls) から n 個を選ぶ組み合わせを combination で求めて、関数 append で連結するだけです。
●解答33
リスト : 重複組み合わせ
(define (repeat-comb n ls)
(cond ((= n 0) (list '()))
((single? ls) (list (make-list (car ls) n)))
(else
(append
(map (lambda (x) (cons (car ls) x))
(repeat-comb (- n 1) ls))
(repeat-comb n (cdr ls))))))
重複組み合わせを求める repeat-comb も簡単です。2 番目の節で、リスト ls に要素が一つしかない場合は、その要素を n 個選びます。make_list で (car ls) を n 個格納したリストを生成します。最後の節では、先頭の要素を選んだあと、それを取り除かないで ls から n - 1 個の要素を選びます。
●解答34
リスト : n 番目の要素で分割する (define (split-nth ls n) (values (take ls n) (drop ls n)))
split-nth は take と drop を使うと簡単です。take で先頭から n 個の要素を取り出し、drop で先頭から n 個の要素を取り除きます。そして、2 つのリストを values で返します。
●解答35
リスト : リストの要素を偶数番目と奇数番目で分ける
(define (partition ls)
(define (odd-part ls xs ys)
(if (null? ls)
(values (reverse! xs) (reverse! ys))
(even-part (cdr ls) xs (cons (car ls) ys))))
(define (even-part ls xs ys)
(if (null? ls)
(values (reverse! xs) (reverse! ys))
(odd-part (cdr ls) (cons (car ls) xs) ys)))
(even-part ls '() '()))
;
(define (partition-i ls)
(let loop ((n 0) (ls ls) (xs '()) (ys '()))
(cond ((null? ls)
(values (reverse! xs) (reverse! ys)))
((zero? n)
(loop 1 (cdr ls) (cons (car ls) xs) ys))
(else
(loop 0 (cdr ls) xs (cons (car ls) ys))))))
奇数番目の要素は局所関数 odd-part で、偶数番目の要素は局所関数 even-part で取り出すと簡単です。この場合、odd-part と even-part は相互再帰になります。別解は named let でプログラムしたもので、第 1 引数 n で奇数番目と偶数番目を判別しています。
●解答36
リスト : x と等しい要素の位置で分割
(define (split-find x ls)
(cond ((null? ls) (values '() '()))
((eqv? (car ls) x) (values '() ls))
(else
(receive (a b) (split-find x (cdr ls))
(values (cons (car ls) a) b)))))
; 別解
(define (split-find-i x ls)
(let loop ((ls ls) (a '()))
(cond ((null? ls)
(values (reverse! a) '()))
((eqv? (car ls) x)
(values (reverse! a) ls))
(else
(loop (cdr ls) (cons (car ls) a))))))
最初の節で引数 ls が空リストの場合、values で空リストを 2 つ返します。次の節で、先頭の要素 (car ls) と x を eqv? で比較して、等しい場合は空リストと ls を返します。最後の節で、split-find を再帰呼び出しして、返り値 (多値) を receive で受け取ります。そして、リスト a の先頭に ls の先頭要素 (car ls) を追加して、values で b といっしょに返します。別解は named let で書き直したものです。
●解答37
リスト : リストを x よりも大きい要素と x 以下の要素に分ける
(define (split-ge x ls)
(if (null? ls)
(values '() '())
(receive (a b) (split-ge x (cdr ls))
(if (< (car ls) x)
(values (cons (car ls) a) b)
(values a (cons (car ls) b))))))
; 別解
(define (split-ge-i x ls)
(let loop ((ls ls) (xs '()) (ys '()))
(cond ((null? ls)
(values (reverse! xs) (reverse! ys)))
((< (car ls) x)
(loop (cdr ls) (cons (car ls) xs) ys))
(else
(loop (cdr ls) xs (cons (car ls) ys))))))
引数 ls が空リストの場合は空リストを 2 つ返します。else 節で、split-ge を再帰呼び出しし、返り値 (多値) を receive で受け取ります。(car ls) が x よりも小さい場合はリスト a に追加し、そうでない場合は b に追加して返します。別解は named let で書き直したものです。
●解答38
リスト : 連続した同じ記号を部分リストにまとめる
; 先頭から連続している記号を取り除く
(define (drop-same-code ls)
(let loop ((ls (cdr ls)) (xs (list (car ls))))
(if (or (null? ls)
(not (eqv? (car xs) (car ls))))
(values xs ls)
(loop (cdr ls) (cons (car ls) xs)))))
(define (pack ls)
(receive (xs ys) (drop-same-code ls)
(if (null? ys)
(list xs)
(cons xs (pack ys)))))
; 別解 1
(define (pack ls)
(let loop ((ls (cdr ls)) (xs (list (car ls))) (ys '()))
(cond ((null? ls)
(reverse! (cons xs ys)))
((eqv? (car ls) (car xs))
(loop (cdr ls) (cons (car ls) xs) ys))
(else
(loop (cdr ls) (list (car ls)) (cons xs ys))))))
; 別解 2
(define (pack ls)
(reverse!
(fold
(lambda (x a)
(if (eqv? x (caar a))
(cons (cons x (car a)) (cdr a))
(cons (list x) a)))
(list (list (car ls)))
(cdr ls))))
pack は関数 drop-same-code を定義すると簡単です。drop-same-code は先頭から連続している記号を変数 xs に格納し、それを取り除いたリストといっしょに返します。pack は drop-same-code の返り値 (多値) を receive で受け取り、ys が空リストであれば、(list xs) を返します。そうでなければ、ys に対して pack を再帰呼び出しし、その返り値の先頭に xs を追加します。別解 1 は drop-same-code を使わずに named-let で書き直したもので、別解 2 は fold を使ったものです。
●解答39
リスト : 連続している数列を (s . e) で表す
(define (pack-num-list ls)
(define (push-num s e a)
(if (= s e) (cons s a) (cons (cons s e) a)))
(let loop ((ls (cdr ls)) (s (car ls)) (e (car ls)) (a '()))
(cond ((null? ls)
(reverse! (push-num s e a)))
((= (car ls) (+ e 1))
(loop (cdr ls) s (car ls) a))
(else
(loop (cdr ls) (car ls) (car ls) (push-num s e a))))))
named let の引数 s が start を、引数 e が終点を表します。引数 a は累積変数として使います。最初の節で ls が空リストの場合は、push-num で a に (s . e) を追加して、その結果を反転して返します。次の節で、(car ls) が e + 1 と等しい場合は連続した数字です。loop を再帰呼び出しするとき、引数 e に (car ls) を渡します。そうでなければ、引数 s, e に (car ls) を渡して、push-num で引数 a に (s . e) を追加して、loop を再帰呼び出しします。
●解答40
リスト : (s . e) を数列に戻す
(define (expand-num-list ls)
(cond ((null? ls) '())
((pair? (car ls))
(append (iota (caar ls) (cdar ls))
(expand-num-list (cdr ls))))
(else
(cons (car ls) (expand-num-list (cdr ls))))))
; 別解
(define (expand-num-list ls)
(define (expand-number s e a)
(if (< e s)
a
(expand-number (+ s 1) e (cons s a))))
(reverse!
(fold
(lambda (x a)
(if (pair? x)
(expand-number (car x) (cdr x) a)
(cons x a)))
'()
ls)))
expand-num-list は iota を使うと簡単です。最初の節が再帰の停止条件です。次の節で、(s . e) を iota で数列に変換します。expand-num-list を再帰呼び出しして残りのリスト (cdr ls) を数列に戻し、そのリストと iota で変換したリストを append で連結します。最後の節はリストの要素が数値の場合で、残りのリスト (cdr ls) を数列に変換し、そのリストの先頭に (car ls) を追加します。別解は fold を使ったバージョンです。
●解答41
リスト : ランレングス符号化
(define (encode ls)
(map
(lambda (xs) (cons (car xs) (length xs)))
(pack ls)))
; 別解
(define (encode ls)
(let loop ((ls (cdr ls)) (code (car ls)) (n 1) (a '()))
(cond ((null? ls)
(reverse! (cons (cons code n) a)))
((eqv? (car ls) code)
(loop (cdr ls) code (+ n 1) a))
(else
(loop (cdr ls) (car ls) 1 (cons (cons code n) a))))))
encode は pack を使うと簡単です。pack の返り値を map で (code . n) に変換するだけです。別解は pack を使わずに named let による繰り返しで連続した記号の数をカウントしています。
●解答42
リスト : ランレングス復号
(define (decode ls)
(flatmap (lambda (xs)
(make-list (car xs) (cdr xs)))
ls))
; 別解
(define (decode ls)
(if (null? ls)
'()
(append (make-list (caar ls) (cdar ls))
(decode (cdr ls)))))
ランレングスの復号は関数 flatmap と make-list を使うと簡単です。make-list で (code . n) をリストに変換し、flatmap でそれを平坦化するだけです。別解は単純な再帰呼び出してプログラムしたものです。
●解答43
リスト : any と every
(define (any? pred ls)
(cond ((null? ls) #f)
((pred (car ls)) #t)
(else
(any? pred (cdr ls)))))
(define (every? pred ls)
(cond ((null? ls) #t)
((pred (car ls))
(every? pred (cdr ls)))
(else #f)))
any と every は簡単です。(pred (car ls)) が真を返す場合、any は #t を返します。逆に偽を返す場合、every は #f を返します。それ以外の場合は再帰呼び出しして次の要素をチェックします。引数のリストが空リストになった場合、any は #f を返し、every は #t を返します。
なお、Scheme の SRFI-1 には any?, every? よりもも高機能の関数 any と every があります。
●解答44
リスト : maplist
(define (maplist fn ls)
(if (null? ls)
'()
(cons (fn ls) (maplist fn (cdr ls)))))
maplist は簡単です。関数 fn に引数のリスト ls をそのまま渡すだけです。maplist を再帰呼び出しするときは、先頭の要素を取り除いたリスト (cdr ls) を渡します。maplist を使うと map は次のように定義することができます。
リスト : map の定義 (define (map fn ls) (maplist (lambda (x) (fn (car x))) ls))
●解答45
リスト : リスト操作の一般化
(define (for-each-list fn comb term ls)
(if (null? ls)
term
(comb (fn (car ls)) (for-each-list fn comb term (cdr ls)))))
関数 for-each-list の引数 fn はリストの要素に適用する関数、comb は fn の返り値と for-each-list の返り値を結合する関数、term はリストの終端で返す値です。プログラムは簡単で、引数のリストが空リストならば term を返します。そうでなければ、リストの要素 (car ls) に関数 fn を適用し、その返り値と for-each-list の返り値を関数 comb で結合します。
なお、次のように一般化することもできます。
リスト : リスト操作の一般化 (2)
(define (for-each-list fn comb term ls)
(if (null? ls)
term
(comb (fn ls) (for-each-list fn comb term (cdr ls)))))
関数 fn に渡すのはリストの要素 (car ls) ではなく、リスト ls を渡しています。
●解答46
リスト : マッピング、フィルター、畳み込み
(define (map fn ls)
(for-each-list fn cons '() ls))
(define (filter pred ls)
(for-each-list (lambda (x) (if (pred x) (list x) '())) append '() ls))
(define (fold-right fn a ls)
(for-each-list (lambda (x) x)
(lambda (x y) (fn x y))
a
ls))
map は comb に cons を、term に ( ) を渡せば実現できます。filter はリストの要素 x に関数 fn を適用し、真を返す場合は (list x) を返し、偽の場合は ( ) を返します。それを append で連結すると、( ) はリストの要素に含まれないので、フィルターとして動作します。fold-right も簡単です。(lambda (x) x) でリストの要素をそのまま返し、要素を連結する関数の中で関数 fn を呼び出します。
なお、リスト操作の一般化 (2) で示した for-each-list を使うと、map, maplist, filter, fold-right は次のようになります。
リスト : マッピング、フィルター、畳み込み (2) (define (map fn ls) (for-each-list (lambda (xs) (fn (car xs))) cons '() ls)) (define (maplist fn ls) (for-each-list (lambda (xs) (fn xs)) cons '() ls)) (define (filter fn ls) (for-each-list car (lambda (x y) (if (fn x) (cons x y) y)) '() ls)) (define (fold-right fn a ls) (for-each-list car (lambda (x y) (fn x y)) a ls))
●解答47
リスト : 小町分数
(define (solve-47)
(define (calc-1 a b c)
(/ a (+ (* b 10) c)))
(define (calc-2 ls)
(apply + (map (lambda (xs) (apply calc-1 xs)) (group ls 3))))
(define (print-1 a b c)
(format #t "~D/~D~D" a b c))
(define (print-2 ls n)
(apply print-1 (car ls))
(display " + ")
(apply print-1 (cadr ls))
(display " + ")
(apply print-1 (caddr ls))
(display " = ")
(display n)
(newline))
;
(for-each
(lambda (ls)
(let ((n (calc-2 ls)))
(if (and (integer? (/ n))
(< (list-ref ls 0) (list-ref ls 3) (list-ref ls 6)))
(print-2 (group ls 3) n))))
(permutation 9 (iota 1 9))))
単純な生成検定法です。重複解を排除するため、A < D < G の条件を付けています。また、順列を生成するとき、このチェックを入れることで枝刈りと同じ効果を得ることができます。興味のある方は試してみてください。実行結果は次のようになります。
gosh> (solve-47) 1/24 + 3/56 + 7/98 = 1/6 1/26 + 5/39 + 7/84 = 1/4 1/32 + 5/96 + 7/84 = 1/6 1/38 + 2/95 + 4/76 = 1/10 1/48 + 5/32 + 7/96 = 1/4 1/56 + 3/72 + 9/84 = 1/6 1/96 + 5/32 + 7/84 = 1/4 1/96 + 5/48 + 7/32 = 1/3 2/18 + 5/63 + 7/49 = 1/3 2/19 + 4/57 + 6/38 = 1/3 3/27 + 6/54 + 9/81 = 1/3 3/48 + 5/16 + 9/72 = 1/2 3/54 + 6/72 + 9/81 = 1/4 5/34 + 7/68 + 9/12 = 1 #<undef>
●解答48
リスト : 魔方陣
(define (solve-48)
(define line '((0 1 2) (3 4 5) (6 7 8) (0 3 6)
(1 4 7) (2 5 8) (0 4 8) (2 4 6)))
(define (calc-line ls a b c)
(+ (list-ref ls a) (list-ref ls b) (list-ref ls c)))
(define (check ls)
(let ((n (apply calc-line ls (car line))))
(every? (lambda (xs) (= n (apply calc-line ls xs))) (cdr line))))
;
(for-each
(lambda (ls)
(if (check ls) (display ls)))
(permutation 9 (iota 1 9))))
単純な生成検定法です。実行結果は次のようになります。
gosh> (solve-48) (2 7 6 9 5 1 4 3 8)(2 9 4 7 5 3 6 1 8)(4 3 8 9 5 1 2 7 6)(4 9 2 3 5 7 8 1 6) (6 1 8 7 5 3 2 9 4)(6 7 2 1 5 9 8 3 4)(8 1 6 3 5 7 4 9 2)(8 3 4 1 5 9 6 7 2)#<undef>
解は 8 通り出力されましたが、重複解を取り除くと解は一通りしかありません。重複解のチェックは面倒だと思われる方もいるでしょう。ところが、下図のように四隅の大小関係を利用すると簡単です。
図 : 対称解のチェック
魔方陣の場合、回転解が 4 種類あって、鏡像解が 2 種類あります。四隅の大小関係をチェックすることで、これらの対称解を排除することができます。また、順列を生成するとき、重複解のチェックを入れると枝刈りと同じ効果を得ることができます。興味のある方は試してみてください。
●解答49
リスト : 小町覆面算
(define (solve-49)
(define (calc-word ls a b c d e)
(+ (* (list-ref ls a) 10000)
(* (list-ref ls b) 1000)
(* (list-ref ls c) 100)
(* (list-ref ls d) 10)
(list-ref ls e)))
;
(for-each
(lambda (ls)
(let ((wrong (calc-word ls 0 1 2 3 4))
(right (calc-word ls 1 5 4 6 7))
(m (list-ref ls 8)))
(if (= (* wrong m) right)
(format #t "~D * ~D = ~D~%" wrong m right))))
(permutation 9 (iota 1 9))))
単純な生成検定法です。実行結果は次のようになります。
gosh> (solve-49) 16958 * 4 = 67832 #<undef>
●解答50
素数を求める基本的な考え方は簡単です。最初に、2 から n までの整数列を生成します。先頭の 2 は素数なので、この整数列から 2 で割り切れる整数を取り除き除きます。2 で割り切れる整数が取り除かれたので、残った要素の先頭が素数になります。先頭要素は 3 になるので、今度は 3 で割り切れる整数を取り除けばいいのです。このように、素数を見つけたらそれで割り切れる整数を取り除いていくアルゴリズムを「エラトステネスの篩 (ふるい) 」といいます。
プログラムは次のようになります。
リスト : 素数 (エラトステネスの篩)
(define (remove-if pred ls)
(cond ((null? ls) '())
((pred (car ls))
(remove-if pred (cdr ls)))
(else
(cons (car ls) (remove-if pred (cdr ls))))))
(define (sieve n)
(let loop ((ls (iota 2 n)) (a '()))
(if (null? ls)
(reverse! a)
(loop
(remove-if (lambda (x) (zero? (modulo x (car ls))))
(cdr ls))
(cons (car ls) a)))))
sieve の処理は named let で行います。iota で 2 から n までの整数列を生成し、それを引数 ls に渡します。loop の中で、ls の先頭要素で割り切れる要素を remove-if で取り除きます。このとき、累積変数 a に (car ls) を追加します。ls が空リストになったら、reverse! でリスト a を反転して返します。
●別解 (2012/10/08)
関数 sieve には無駄な処理があります。リストの先頭要素 x が √n よりも大きい場合、リストには素数しか残っていません。つまり、ふるいにかけるのは x <= √n まででいいのです。これをプログラムすると次のようになります。
リスト : 別解
(define (reverse-append xs ys)
(if (null? xs)
ys
(reverse-append (cdr xs) (cons (car xs) ys))))
(define (sieve1 n)
(let loop ((xs (iota 2 n)) (a '()))
(if (null? xs)
(reverse! a)
(let ((x (car xs)))
(if (< n (* x x))
(reverse-append a xs)
(loop
(remove-if (lambda (y) (zero? (modulo y x))) (cdr xs))
(cons x a)))))))
name-let の中で、リストの先頭要素 x が x * x > n ならば、累積変数 a とリスト xs を関数 reverse-append で連結して返します。これで sieve よりも速く素数を求めることができます。
remove-if のかわりにリストを破壊的に修正する関数を用意すると、実行速度はもうすこし速くなります。次のリストを見てください。
リスト : 別解 (2)
(define (delete-if pred xs)
(let ((top (cons #f xs)))
(let loop ((cp top))
(cond ((null? (cdr cp)) (cdr top))
((pred (cadr cp))
(set-cdr! cp (cddr cp))
(loop cp))
(else
(loop (cdr cp)))))))
(define (sieve2 n)
(let loop ((xs (iota 2 n)) (a '()))
(if (null? xs)
(reverse! a)
(let ((x (car xs)))
(if (< n (* x x))
(reverse-append a xs)
(loop
(delete-if (lambda (y) (zero? (modulo y x))) (cdr xs))
(cons x a)))))))
関数 delete-if はリストを破壊的に修正します。関数名は Common Lisp から拝借しました。Scheme の場合、同等の機能を持つ関数 remove! が SRFI-1 に用意されています。関数 sieve2 は remove-if のかわりに delete-if を呼び出すだけです。
ところで、「エラトステネスの篩」はベクタを使ってプログラムしたほうが高速になります。次のリストを見てください。
リスト : ベクタ版
(define (sieve3 n)
(let ((p (make-vector (+ (quotient n 2) 1) #t))
(a (list 2)))
(do ((i 3 (+ i 2)) (j 1 (+ j 1)))
((< n (* i i))
;
(do ((i i (+ i 2)) (j j (+ j 1)))
((< n i) (reverse! a))
(when (vector-ref p j)
(push! a i))))
(when (vector-ref p j)
(push! a i)
(do ((k (+ j i) (+ k i)))
((<= (vector-length p) k))
(vector-set! p k #f))))))
真偽値を格納するベクタ p で奇数列 (1, 3, 5, 7, ... ) を表します。#t で素数を表し、素数でない場合は #f に書き換えます。ベクタ p は #t で初期化されるので、最初はすべての数が素数ということになります。
プログラムでは、奇数を変数 i で、それに対応するベクタ p の添字を変数 j で表します。変数 i は 3, 5, 7, 9, ... に、それに対応する変数 j は 1, 2, 3, 4, ... になります。この場合、i の倍数に対応する j の値は j + i, j + i * 2, j + i * 3, ... になります。たとえば、3, 5, 7 の倍数は次のようになります。
i | 3 5 7 9 11 13 15 17 19 21 23 25 j | 1 2 3 4 5 6 7 8 9 10 11 12 --+------------------------------------- 3 | O 0 O 0 5 | 0 0 0 7 | 0 0
プログラムは簡単です。最初の do ループで i が √n 以下の処理を行います。この中で素数 i の倍数を削除します。そのあと、ベクタ p に残された素数をリスト a に格納して返します。
それでは実行結果を示します。
実行結果
---------------------------
(sieve1 1000000) : 3.90 秒
(sieve2 1000000) : 1.75 秒
(sieve3 1000000) : 0.09 秒
実行環境 : Windows 7, Core i7-2670QM 2.20GHz, Gauche version 0.9.2
ベクタを使った sieve3 が一番速くなりました。