以前の Scheme の仕様 (R5RS) はとてもコンパクトでした。直近の仕様 (R7RS) は samll と large に分かれましたが、R7RS-small の方はコンパクトにまとめられていると思います。R5RS は必要最低限の機能しか定義されていないため、多くの Scheme 処理系で機能追加や拡張が行われていました。この拡張機能の標準化を目的に Scheme Requests For Implementation (SRFI) という仕様が定められています。
その中で、SRFI-1 にはリスト操作を行う関数が多数定義されています。SRFI-1 は Gauche でもサポートされていますが、今回は Scheme のお勉強ということで、SRFI-1 や Common Lisp を参考にして、ちょっと便利なリスト操作関数や高階関数をいくつか作ってみましょう。
最初は数列を生成する関数 iota と tabulate を作りましょう。iota は n 個の数列を生成する関数です。
start から始まり step ずつ増加する数列を生成します。start が省略された場合は 0 から始まり、step が省略されると 1 ずつ増加する数列になります。iota は 数当てゲーム [1] の問題 4 で取り上げましたが、そのプログラムとは仕様が異なるので注意してください。
プログラムは case-lambda を使うと簡単です。次のリストを見てください。
リスト : 数列の生成
(define iota
(case-lambda
((n) (iota n 0 1))
((n s) (iota n s 1))
((n s i)
(if (zero? n)
'()
(cons s (iota (- n 1) (+ s i) i))))))
(iota n) の場合は (iota n 0 1) を呼び出し、(iota n s) の場合は (iota n s 1) を呼び出します。(iota n s i) が本体で、s から始まって i 刻みの数を n 個生成します。
簡単な実行例を示します。
gosh[r7rs.user]> (iota 10) (0 1 2 3 4 5 6 7 8 9) gosh[r7rs.user]> (iota 10 1) (1 2 3 4 5 6 7 8 9 10) gosh[r7rs.user]> (iota 10 1 2) (1 3 5 7 9 11 13 15 17 19) gosh[r7rs.user]> (iota 10 1 -2) (1 -1 -3 -5 -7 -9 -11 -13 -15 -17)
関数 tabulate は iota で生成した数列に関数 fn を適用した結果をリストに格納して返します。
tabulate は (map fn (iota n)) と同じですが、この方法では iota で新しいリストを生成し、なおかつ map で新しいリストを生成することになります。tabulate は数列を生成しながら関数 fn を適用するので、無駄なリストを生成することがありません。tabulate は Scheme プログラミング中級編 [1] の問題 2 で取り上げましたが、そのプログラムとは仕様が異なるので注意してください。
プログラムは次のようになります。
リスト : 数列の生成 (2)
(define tabulate
(case-lambda
((fn n) (tabulate fn n 0 1))
((fn n s) (tabulate fn n s 1))
((fn n s i)
(if (zero? n)
'()
(cons (fn s) (tabulate fn (- n 1) (+ s i) i))))))
tabulate は生成した数値 s に関数 fn を適用し、その結果をリストに格納するだけです。簡単な実行例を示します。
gosh[r7rs.user]> (tabulate (lambda (x) x) 10) (0 1 2 3 4 5 6 7 8 9) gosh[r7rs.user]> (tabulate (lambda (x) (* x x)) 10) (0 1 4 9 16 25 36 49 64 81) gosh[r7rs.user]> (tabulate (lambda (x) (* x x)) 10 1 2) (1 9 25 49 81 121 169 225 289 361)
次はリストの先頭から n 個の要素を取り出す関数 take とリストの先頭から n 個の要素を取り除く関数 drop を作りましょう。
なお、R7RS-Small には drop と同様の関数 list-tail があります。
take と drop は Scheme の基礎知識 [4] の問題 3, 4 で取り上げました。プログラムは次のようになります。
リスト : take と drop
;;; リストの先頭から n 個の要素を取り出す
(define (take ls n)
(if (or (zero? n) (null? ls))
'()
(cons (car ls) (take (cdr ls) (- n 1)))))
;;; リストの先頭から n 個の要素を取り除く
(define (drop ls n)
(if (or (zero? n) (null? ls))
ls
(drop (cdr ls) (- n 1))))
take はリスト ls の先頭から n 個の要素を取り出してリストに格納して返します。リストの長さが n 以下の場合は、リストをコピーして返すことになります。drop は先頭から n 個の要素を取り除きます。つまり、リスト ls に n 回 cdr を適用することになります。これは Common Lisp の関数 nthcdr と同じ動作です。
なお、このプログラムは Gauche (SRFI-1) と動作が異なり、引数 n がリスト ls の長さより大きくてもエラーにはなりません。問題 3, 4 の解答プログラムや Gauche ではエラーになるので注意してください。
それでは簡単な応用例として、一つのリストを長さ n の部分リストに分ける関数 group を作ってみましょう。
リスト : リストを部分リストに分ける
(define (group ls n)
(if (null? ls)
'()
(cons (take ls n) (group (drop ls n) n))))
関数 group は take の返り値と group を再帰呼び出しした返り値を cons で連結するだけです。group を再帰呼び出しするときは、drop で先頭から n 個の要素を取り除くことに注意してください。
それでは実行してみましょう。
gosh[r7rs.user]> (take '(a b c d e) 2) (a b) gosh[r7rs.user]> (drop '(a b c d e) 2) (c d e) gosh[r7rs.user]> (group '(a b c d e) 2) ((a b) (c d) (e)) gosh[r7rs.user]> (group '(a b c d e f) 2) ((a b) (c d) (e f))
マッピングは拙作のページ Scheme プログラミング中級編 [1] で説明しました。このとき作成したマップ関数は、関数と一つのリストしか受け取ることができません。R5RS, R7RS-small と SRFI-1 のマップ関数は複数のリストを渡しても動作します。今回は複数のリストを受け付けるようにマップ関数を修正しましょう。次のリストを見てください。
リスト : マップ関数
(define (map-1 fn xs)
(if (null? xs)
'()
(cons (fn (car xs)) (map-1 fn (cdr xs)))))
(define (map-n fn xss)
(if (member '() xss)
'()
(cons (apply fn (map car xss))
(map-n fn (map cdr xss)))))
(define mapn
(case-lambda
((fn xs)
(map-1 fn xs))
((fn xs . args)
(map-n fn (cons xs args)))))
関数名は mapn としました。関数 map-1 は Scheme プログラミング中級編 [1] で作成したマップ関数 my-map と同じです。関数 map-n の引数 xss はリストで、ここに複数のリストを格納して渡します。関数 mapn は case-lambda で場合分けして、引数が 2 つであれば map-1 を、3 つ以上あれば map-n を呼び出します。
関数 map-n は、最初に xss の要素に空リストがあるかチェックします。R5RS では、引数のリストの長さは同じでなければいけなかったのですが、R7RS-samll ではリストの長さが異なっていてもかまいません。今回のプログラムのように、一番短いリストの要素がなくなった時点で処理を終了します。
空リストがない場合、(map-1 car args) でリストから先頭要素を取り出し、それを fn に渡して評価します。これは apply を使えば簡単です。それから、map-n を再帰呼び出しします。このとき、(map-1 cdr xs) で各リストの先頭要素を取り除きます。その返り値に fn の評価結果を追加すればいいわけです。これで複数のリストに対してマッピングを行うことができます。
簡単な実行例を示します。
gosh[r7rs.user]> (mapn - '(1 2 3 4 5)) (-1 -2 -3 -4 -5) gosh[r7rs.user]> (mapn + '(1 2 3) '(4 5 6 7)) (5 7 9) gosh[r7rs.user]> (mapn * '(1 2 3) '(4 5 6) '(7 8)) (28 80)
map fn xs はリスト xs の要素に関数 fn を適用しますが、関数 fn にリストそのものを渡すマップ関数を考えることができます。ただし、繰り返すたびにリストの先頭要素は取り除かれていきます。Common Lisp では、このような処理を行う関数を maplist といいます。maplist は Scheme プログラミング中級編 [1] の問題 4 で取り上げました。このプログラムを複数のリストを受け付けるように改良すると次のようになります。
リスト : リスト xs に関数 fn を適用する
(define (mapl-1 fn xs)
(if (null? xs)
'()
(cons (fn xs) (mapl-1 fn (cdr xs)))))
(define (mapl-n fn xss)
(if (member '() xss)
'()
(cons (apply fn xss) (mapl-n fn (map cdr xss)))))
(define maplist
(case-lambda
((fn xs)
(mapl-1 fn xs))
((fn xs . args)
(mapl-n fn (cons xs args)))))
maplist の引数が 2 つの場合、関数 mapl-1 を呼び出します。3 つ以上の場合は関数 mapl-n を呼び出します。mapl-n は apply で関数 fn を呼び出すとき、引数 xss をそのまま渡すだけです。簡単な使用例を示しましょう。
gosh[r7rs.user]> (maplist (lambda (xs) xs) '(a b c d e)) ((a b c d e) (b c d e) (c d e) (d e) (e)) gosh[r7rs.user]> (maplist (lambda (xs) (length xs)) '(a b c d e)) (5 4 3 2 1) gosh[r7rs.user]> (define (mapn fn xs . args) (apply maplist (lambda ys (apply fn (map car ys))) xs args)) mapn gosh[r7rs.user]> (mapn (lambda (x) (* x x)) '(1 2 3 4 5)) (1 4 9 16 25) gosh[r7rs.user]> (mapn (lambda (x y) (cons x y)) '(a b c d e) '(1 2 3 4 5)) ((a . 1) (b . 2) (c . 3) (d . 4) (e . 5))
map (mapn) は maplist と car を使って簡単に定義することできます。
もうひとつ、ちょっと便利なマップ関数を作ってみましょう。関数 map-with-index は引数の関数 fn の第 1 引数に要素の添字を渡します。
リスト : 添字付きマップ関数
(define (mapi-1 fn xs i)
(if (null? xs)
'()
(cons (fn i (car xs)) (mapi-1 fn (cdr xs) (+ i 1)))))
(define (mapi-n fn xss i)
(if (member '() xss)
'()
(cons (apply fn i (map car xss))
(mapi-n fn (map cdr xss) (+ i 1)))))
(define map-with-index
(case-lambda
((fn xs)
(mapi-1 fn xs 0))
((fn xs . args)
(mapi-n fn (cons xs args) 0))))
map-with-index の引数 が 2 つの場合は関数 mapi-1 を呼び出し、3 つ以上の場合は関数 mapi-n を呼び出します。どちらの関数も引数 i が添字を表します。関数 fn を呼び出すとき、第 1 引数に i を渡すだけです。
gosh[r7rs.user]> (map-with-index (lambda (i x) (list i x)) '(a b c d e f)) ((0 a) (1 b) (2 c) (3 d) (4 e) (5 f)) gosh[r7rs.user]> (map-with-index (lambda (i x y) (list i x y)) '(a b c) '(d e f)) ((0 a d) (1 b e) (2 c f))
フィルター (filter) はリストの要素に述語 pred を適用し、pred が真を返す要素をリストに格納して返す関数です。Scheme プログラミング中級編 [1] では filter と remove-if を作りましたが、Common Lisp の remove のように、引数 x と等しい要素を削除する関数があると便利です。
remove はリスト xs から x と等しい要素を削除します。test? は等値を判定する述語です。省略された場合、Common Lisp はデフォルトで eql を使うので、今回は eqv? を使うことにします。remove は remove-if と case-lambda を使うと簡単に定義することができます。プログラムは次のようになります。
リスト : リストの修正
(define (remove-if pred xs)
(cond
((null? xs) '())
((pred (car xs))
(remove-if pred (cdr xs)))
(else
(cons (car xs) (remove-if pred (cdr xs))))))
(define remove
(case-lambda
((x xs)
(remove-if (lambda (y) (eqv? x y)) xs))
((x xs pred)
(remove-if (lambda (y) (pred x y)) xs))))
remove の引数が 2 つの場合は eqv? を、3 つの場合は第 3 引数の pred を使うだけです。簡単な実行例を示します。
gosh[r7rs.user]> (remove 1 '(1 2 3 1 2 3 1 2 3)) (2 3 2 3 2 3) gosh[r7rs.user]> (remove '(1 2) '((1 2) (3 1) (2 3) (1 2 3))) ((1 2) (3 1) (2 3) (1 2 3)) gosh[r7rs.user]> (remove '(1 2) '((1 2) (3 1) (2 3) (1 2 3)) equal?)
拙作のページ Scheme プログラミング中級編 [1] では、畳み込みを行う関数 foldl と foldr を作成しましたが、リストは一つしか受け取ることができません。今回は複数のリストを受け取ることができるように改良してみましょう。次のリストを見てください。
リスト : 畳み込み
(define (foldl-1 fn a xs)
(if (null? xs)
a
(foldl-1 fn (fn a (car xs)) (cdr xs))))
(define (foldl-n fn a xss)
(if (member '() xss)
a
(foldl-n fn (apply fn a (map car xss)) (map cdr xss))))
(define foldl
(case-lambda
((fn a xs)
(foldl-1 fn a xs))
((fn a xs . args)
(foldl-n fn a (cons xs args)))))
(define (foldr-1 fn a xs)
(if (null? xs)
a
(fn (foldr-1 fn a (cdr xs)) (car xs))))
(define (foldr-n fn a xss)
(if (member '() xss)
a
(apply fn (foldr-n fn a (map cdr xss)) (map car xss))))
(define foldr
(case-lambda
((fn a xs)
(foldr-1 fn a xs))
((fn a xs . args)
(foldr-n fn a (cons xs args)))))
mapn と同様に、引数の個数により case-lambda で場合分けします。foldl-n, foldr-n は引数 xss に複数のリストを受け取ります。xss に空リストがあれば累積変数 a を返します。関数 fn を呼び出すとき、どちらの関数も fn の第 1 引数に累積変数 a を渡し、それ以降の引数にリストの要素を渡します。今まで作成した foldr とは引数の順番が異なることに注意してください。
簡単な実行例を示します。
gosh[r7rs.user]> (foldl + 0 '(1 2 3 4 5)) 15 gosh[r7rs.user]> (foldr + 0 '(1 2 3 4 5)) 15 gosh[r7rs.user]> (define (xcons d a) (cons a d)) xcons gosh[r7rs.user]> (foldl xcons '() '(1 2 3 4 5)) (5 4 3 2 1) gosh[r7rs.user]> (foldr xcons '() '(1 2 3 4 5)) (1 2 3 4 5) gosh[r7rs.user]> (foldl (lambda (a x y) (cons (list x y) a)) '() '(a b c) '(d e f)) ((c f) (b e) (a d)) gosh[r7rs.user]> (foldr (lambda (a x y) (cons (list x y) a)) '() '(a b c) '(d e f)) ((a d) (b e) (c f))
Scheme プログラミング中級編 [1] の問題 6, 7 で取り上げた関数 scan-left, scan-right は、計算途中の累積変数の値をリストに格納して返します。ここでは、複数のリストを受け付ける関数 scanl と scanr を作りましょう。次のリストを見てください。
リスト : scanl と scanr
(define (scanl-1 fn a xs)
(if (null? xs)
(list a)
(cons a (scanl-1 fn (fn a (car xs)) (cdr xs)))))
(define (scanl-n fn a xss)
(if (member '() xss)
(list a)
(cons a (scanl-n fn (apply fn a (map car xss)) (map cdr xss)))))
(define scanl
(case-lambda
((fn a xs)
(scanl-1 fn a xs))
((fn a xs . args)
(scanl-n fn a (cons xs args)))))
(define (scanr-1 fn a xs)
(if (null? xs)
(list a)
(let ((ys (scanr-1 fn a (cdr xs))))
(cons (fn (car ys) (car xs)) ys))))
(define (scanr-n fn a xss)
(if (member '() xss)
(list a)
(let ((ys (scanr-n fn a (map cdr xss))))
(cons (apply fn (car ys) (map car xss)) ys))))
(define scanr
(case-lambda
((fn a xs)
(scanr-1 fn a xs))
((fn a xs . args)
(scanr-n fn a (cons xs args)))))
mapn と同様に、引数の個数により case-lambda で場合分けします。scanl-n, scanr-n は引数 xss に複数のリストを受け取ります。xss に空リストがあれば (list a) を返します。関数 fn を呼び出すとき、どちらの関数も fn の第 1 引数に累積変数の値を渡し、それ以降の引数にリストの要素を渡します。簡単な使用例を示しましょう。
gosh[r7rs.user]> (scanl + 0 '(1 2 3 4 5 6 7 8 9 10)) (0 1 3 6 10 15 21 28 36 45 55) gosh[r7rs.user]> (scanr + 0 '(1 2 3 4 5 6 7 8 9 10)) (55 54 52 49 45 40 34 27 19 10 0) gosh[r7rs.user]> (scanl (lambda (a x y) (cons (list x y) a)) '() '(a b c) '(d e f)) (() ((a d)) ((b e) (a d)) ((c f) (b e) (a d))) gosh[r7rs.user]> (scanr (lambda (a x y) (cons (list x y) a)) '() '(a b c) '(d e f)) (((a d) (b e) (c f)) ((b e) (c f)) ((c f)) ())
scanl はリストの最後の要素が最終の累積値になります。scanr はリストの先頭の要素が最終の累積値、最後の要素が初期値になります。
ところで、iota や tabulate のようなリストを生成する関数は、次のように一般化することができます。
リスト : 解きほぐし
(define unfold
(case-lambda
((p f g seed)
(unfold p f g seed (lambda (x) '())))
((p f g seed tail)
(if (p seed)
(tail seed)
(cons (f seed) (unfold p f g (g seed) tail))))))
関数 unfold は畳み込みを行う foldl の逆変換に相当する処理で、「解きほぐし」とか「逆畳み込み」と呼ばれています。unfold は値 seed に関数 f を適用し、その要素をリストに格納して返します。引数 p は終了条件を表す関数で、p が真を返すときリストの終端を関数 tail で生成して返します。一般に、tail は空リスト ( ) を返すのが普通なので、第 5 引数を省略できるようにしています。関数 g は seed の値を更新するために使用します。したがって、生成されるリストの要素は次のようになります。
((f (g seed)) ; g を 1 回適用 (f (g (g seed))) ; g を 2 回適用 (f (g (g (g seed)))) ; g を 3 回適用 ... (f (g (g ... (g seed) ...))) ) ; g を n 回適用
リストの長さが n の場合、最後の要素は g を n 回適用し、その結果に f を適用することになります。
簡単な例を示しましょう。
gosh[r7rs.user]> (define (identity x) x) identity gosh[r7rs.user]> (define (1+ x) (+ x 1)) |1+| gosh[r7rs.user]> (unfold (lambda (x) (> x 10)) identity 1+ 1) (1 2 3 4 5 6 7 8 9 10) gosh[r7rs.user]> (unfold (lambda (x) (> x 10)) (lambda (x) (* x x)) 1+ 1) (1 4 9 16 25 36 49 64 81 100)
このように、unfold を使って iota を実現することができます。また、恒等関数 identity のかわりに他の関数を渡すことで、関数 tabulate と同じ動作を実現できます。
もう一つ簡単な例を示しましょう。start から始まって増分値が step で合計値が sum 以上になる数列で、要素が最小個数となるものを求めます。次のリストを見てください。
リスト : 合計値が sum 以上になる数列を求める
(define (unfold-sum sum start step)
(unfold (lambda (x) (<= sum (car x)))
cdr
(lambda (x) (cons (+ (car x) (cdr x)) (+ (cdr x) step)))
(cons 0 start)))
関数名は unfold-sum としました。プログラムは簡単で、リストの要素を start から始めて step ずつ値を増やしていき、合計値が sum 以上になったらリストの生成を終了します。
リストの生成中には、要素の値とそれまでの合計値が必要になります。そこで、これらの値をコンスセルにまとめて unfold の seed に渡すことにします。CAR 部が合計値で、CDR 部が要素の値です。したがって、終了条件は引数の CAR 部が sum 以上になったときで、seed の更新は CAR 部 + CDR 部 と CDR 部 + step の値を cons でまとめたものになります。
簡単な実行例を示します。
gosh[r7rs.user]> (foldl + 0 '(1 2 3 4 5)) 15 gosh[r7rs.user]> (unfold-sum 15 1 1) (1 2 3 4 5) gosh[r7rs.user]> (unfold-sum 16 1 1) (1 2 3 4 5 6) gosh[r7rs.user]> (foldl + 0 '(1 3 5 7 9)) 25 gosh[r7rs.user]> (unfold-sum 25 1 2) (1 3 5 7 9) gosh[r7rs.user]> (unfold-sum 26 1 2) (1 3 5 7 9 11)
要素の合計値がちょうど sum にならない場合もありますが、合計値は sum 以上で要素の個数は最小になっています。なお、合計値が sum 以下で、できるだけ sum に近い数列を生成することもできます。興味のある方はプログラムを作ってみてください。
ところで、unfold の seed は、数値だけではなくリストを渡すこともできます。たとえば、foldr に xcons を渡すとリストをコピーする処理を実現できますが、解きほぐしを行う unfold で car と cdr を渡しても同じを実現することができます。
gosh[r7rs.user]> (foldr xcons '() '(a b c d e)) (a b c d e) gosh[r7rs.user]> (unfold null? car cdr '(a b c d e)) (a b c d e)
なお、リストのコピーは R7RS-small の関数 list-copy で行うことができます。
リストの探索は関数 member, memv, memq で行うことができますが、SRFI-1 にはリストを探索する高階関数 find, find-tail, list-index があります。今回は Common Lisp を参考に、関数 find, find-if, position, position-if, count, count-if を作ってみましょう。
find と find-if は見つけた要素を返します。見つかない場合は #f を返します。position と position-if は見つけた要素の位置を返します。見つからない場合は #f を返します。count と count-if は見つけた要素の個数を返します。見つからない場合は 0 を返します。find, position, count で test? が省略された場合、等値の判定は述語 eqv? を使うことにします。
プログラムは次のようになります。
リスト : リストの探索
(define (find-if pred xs)
(let loop ((xs xs))
(cond
((null? xs) #f)
((pred (car xs)) (car xs))
(else
(find-if pred (cdr xs))))))
(define find
(case-lambda
((x xs)
(find-if (lambda (y) (eqv? x y)) xs))
((x xs pred)
(find-if (lambda (y) (pred x y)) xs))))
(define (position-if pred xs)
(let loop ((i 0) (xs xs))
(cond
((null? xs) #f)
((pred (car xs)) i)
(else
(loop (+ i 1) (cdr xs))))))
(define position
(case-lambda
((x xs)
(position-if (lambda (y) (eqv? x y)) xs))
((x xs pred)
(position-if (lambda (y) (pred x y)) xs))))
(define (count-if pred xs)
(let loop ((c 0) (xs xs))
(if (null? xs)
c
(loop (if (pred (car xs)) (+ c 1) c) (cdr xs)))))
(define count
(case-lambda
((x xs)
(count-if (lambda (y) (eqv? x y)) xs))
((x xs pred)
(count-if (lambda (y) (pred? x y)) xs))))
プログラムは単純な線形探索なので、説明は不要でしょう。簡単な実行例を示します。
gosh[r7rs.user]> a (0 1 2 3 4 5 6 7 8 9) gosh[r7rs.user]> (find 5 a) 5 gosh[r7rs.user]> (find 10 a) #f gosh[r7rs.user]> (find-if (lambda (x) (> x 5)) a) 6 gosh[r7rs.user]> (find-if (lambda (x) (> x 10)) a) #f gosh[r7rs.user]> (position 5 a) 5 gosh[r7rs.user]> (position 10 a) #f gosh[r7rs.user]> (position-if (lambda (x) (> x 5)) a) 6 gosh[r7rs.user]> (position-if (lambda (x) (> x 10)) a) #f gosh[r7rs.user]> (count 5 a) 1 gosh[r7rs.user]> (count 10 a) 0 gosh[r7rs.user]> (count-if even? a) 5 gosh[r7rs.user]> (count-if (lambda (x) (> x 10)) a) 0
次は SRFI-1 に用意されている関数 any と every を作りましょう。
any はリストの要素に述語 pred を適用し、ひとつでも真を返す要素があれば、その要素に pred を適用した結果を返します。すべての要素が偽を返す場合、any は偽を返します。every はリストの要素に述語 pred を適用し、ひとつでも偽を返す要素があれば偽を返します。すべての要素が真を返す場合、最後の要素に pred を適用した結果を返します。
プログラムは次のようになります。
リスト : any と every
(define (every-1 pred xs)
(if (null? xs)
#t
(let ((val (pred (car xs))))
(if (or (not val) (null? (cdr xs)))
val
(every-1 pred (cdr xs))))))
(define (every-n pred xss)
(if (member '() xss)
#t
(let ((val (apply pred (map car xss)))
(yss (map cdr xss)))
(if (or (not val) (member '() yss))
val
(every-n pred yss)))))
(define every
(case-lambda
((pred xs)
(every-1 pred xs))
((pred xs . args)
(every-n pred (cons xs args)))))
(define (any-1 pred xs)
(if (null? xs)
#f
(or (pred (car xs))
(any-1 pred (cdr xs)))))
(define (any-n pred xss)
(if (member '() xss)
#f
(or (apply pred (map car xss))
(any-n pred (map cdr xss)))))
(define any
(case-lambda
((pred xs)
(any-1 pred xs))
((pred xs . args)
(any-n pred (cons xs args)))))
mapn と同様に、引数の個数により case-lambda で場合分けします。any-1 と any-n は簡単です。リストの要素がなくなったら #f を返します。そうでなければ、リストの先頭要素を取り出し、pred を評価します。その結果が偽であれば次の要素をチェックします。or を使っているので、pred の返り値が真であれば、ただちにその値を返すことになります。
every-1 は引数 xs が空リストであれば、every-n は引数 xss に空リストがあれば #t を返します。次に、リストの先頭要素を取り出して、pred を評価して、その結果を変数 val にセットします。val の値が偽、もしくは最後の要素だった場合は val を返します。そうでなければ、次の要素をチェックします。
簡単な実行例を示しましょう。
gosh[r7rs.user]> (any (lambda (x) x) '(#f #f #f #f #f)) #f gosh[r7rs.user]> (any (lambda (x) x) '(#f #f 3 #f #f)) 3 gosh[r7rs.user]> (any (lambda (x) x) '()) #f gosh[r7rs.user]> (every (lambda (x) x) '(1 2 3 4 5)) 5 gosh[r7rs.user]> (every (lambda (x) x) '(1 2 #f 4 5)) #f gosh[r7rs.user]> (every (lambda (x) x) '()) #t gosh[r7rs.user]> (any < '(1 3 5) '(2 0 0)) #t gosh[r7rs.user]> (any < '(1 3 5) '(0 0 0)) #f gosh[r7rs.user]> (every < '(1 3 5) '(2 4 6)) #t gosh[r7rs.user]> (every < '(1 3 5) '(2 4 0)) #f
これらの関数はライブラリとしてまとめておくと簡単に利用することができます。ライブラリ名を (mylib list) として、以下の関数を用意しました。
詳細は プログラムリスト をお読みください。
;;;
;;; list.scm : ちょっと便利なリスト操作関数
;;;
;;; Copyright (C) 2020 Makoto Hiroi
;;;
(define-library (mylib list)
(import (scheme base) (scheme case-lambda))
(export iota tabulate unfold take drop take-while drop-while
rev-append last-pair append! reverse! maplist map-with-index
remove-if remove filter foldl foldr scanl scanr every any
find-if find position-if position count-if count duplicates?
remove-duplicates
)
(begin
;; リストの生成
(define iota
(case-lambda
((n) (iota n 0 1))
((n s) (iota n s 1))
((n s i)
(if (zero? n)
'()
(cons s (iota (- n 1) (+ s i) i))))))
(define tabulate
(case-lambda
((fn n) (tabulate fn n 0 1))
((fn n s) (tabulate fn n s 1))
((fn n s i)
(if (zero? n)
'()
(cons (fn s) (tabulate fn (- n 1) (+ s i) i))))))
;; 逆畳み込み
(define unfold
(case-lambda
((p f g seed)
(unfold p f g seed (lambda (x) '())))
((p f g seed tail)
(if (p seed)
(tail seed)
(cons (f seed) (unfold p f g (g seed) tail))))))
;; take と drop
(define (take xs n)
(if (or (null? xs) (zero? n))
'()
(cons (car xs) (take (cdr xs) (- n 1)))))
(define (drop xs n)
(if (or (null? xs) (zero? n))
xs
(drop (cdr xs) (- n 1))))
(define (take-while pred xs)
(if (or (null? xs) (not (pred (car xs))))
'()
(cons (car xs) (take-wile pred (cdr xs)))))
(define (drop-while pred xs)
(if (or (null? xs) (not (pred (car xs))))
xs
(drop-while pred (cdr xs))))
;; リストを反転して連結する
(define (rev-append xs ys)
(if (null? xs)
ys
(rev-append (cdr xs) (cons (car xs) ys))))
;; 最後のペアを求める
(define (last-pair xs)
(if (null? (cdr xs))
xs
(last-pair (cdr xs))))
;; リストの破壊的連結
(define (append! . xs)
(if (null? xs)
'()
(let loop ((ys xs))
(cond
((null? (cdr ys)) (car xs))
(else
(set-cdr! (last-pair (car ys)) (cadr ys))
(loop (cdr ys)))))))
;; リストの反転 (破壊的)
(define (reverse! ls)
(let loop ((ls ls) (r '()))
(if (null? ls)
r
(let ((x (cdr ls)))
(set-cdr! ls r)
(loop x ls)))))
;; マッピング
(define (mapl-1 fn xs)
(if (null? xs)
'()
(cons (fn xs) (mapl-1 fn (cdr xs)))))
(define (mapl-n fn xss)
(if (member '() xss)
'()
(cons (apply fn xss) (mapl-n fn (map cdr xss)))))
(define maplist
(case-lambda
((fn xs)
(mapl-1 fn xs))
((fn xs . args)
(mapl-n fn (cons xs args)))))
(define (mapi-1 fn xs i)
(if (null? xs)
'()
(cons (fn i (car xs)) (mapi-1 fn (cdr xs) (+ i 1)))))
(define (mapi-n fn xss i)
(if (member '() xss)
'()
(cons (apply fn i (map car xss))
(mapi-n fn (map cdr xss) (+ i 1)))))
(define map-with-index
(case-lambda
((fn xs)
(mapi-1 fn xs 0))
((fn xs . args)
(mapi-n fn (cons xs args) 0))))
;; フィルター
(define (filter pred xs)
(cond
((null? xs) '())
((pred (car xs))
(cons (car xs) (filter pred (cdr xs))))
(else
(filter pred (cdr xs)))))
(define (remove-if pred xs)
(cond
((null? xs) '())
((pred (car xs))
(remove-if pred (cdr xs)))
(else
(cons (car xs) (remove-if pred (cdr xs))))))
(define remove
(case-lambda
((x xs)
(remove-if (lambda (y) (eqv? x y)) xs))
((x xs pred)
(remove-if (lambda (y) (pred x y)) xs))))
;; 畳み込み
(define (foldl-1 fn a xs)
(if (null? xs)
a
(foldl-1 fn (fn a (car xs)) (cdr xs))))
(define (foldl-n fn a xss)
(if (member '() xss)
a
(foldl-n fn (apply fn a (map car xss)) (map cdr xss))))
(define foldl
(case-lambda
((fn a xs)
(foldl-1 fn a xs))
((fn a xs . args)
(foldl-n fn a (cons xs args)))))
(define (foldr-1 fn a xs)
(if (null? xs)
a
(fn (foldr-1 fn a (cdr xs)) (car xs))))
(define (foldr-n fn a xss)
(if (member '() xss)
a
(apply fn (foldr-n fn a (map cdr xss)) (map car xss))))
(define foldr
(case-lambda
((fn a xs)
(foldr-1 fn a xs))
((fn a xs . args)
(foldr-n fn a (cons xs args)))))
(define (scanl-1 fn a xs)
(if (null? xs)
(list a)
(cons a (scanl-1 fn (fn a (car xs)) (cdr xs)))))
(define (scanl-n fn a xss)
(if (member '() xss)
(list a)
(cons a (scanl-n fn (apply fn a (map car xss)) (map cdr xss)))))
(define scanl
(case-lambda
((fn a xs)
(scanl-1 fn a xs))
((fn a xs . args)
(scanl-n fn a (cons xs args)))))
(define (scanr-1 fn a xs)
(if (null? xs)
(list a)
(let ((ys (scanr-1 fn a (cdr xs))))
(cons (fn (car ys) (car xs)) ys))))
(define (scanr-n fn a xss)
(if (member '() xss)
(list a)
(let ((ys (scanr-n fn a (map cdr xss))))
(cons (apply fn (car ys) (map car xss)) ys))))
(define scanr
(case-lambda
((fn a xs)
(scanr-1 fn a xs))
((fn a xs . args)
(scanr-n fn a (cons xs args)))))
;; 述語
(define (every-1 pred xs)
(if (null? xs)
#t
(let ((val (pred (car xs))))
(if (or (not val) (null? (cdr xs)))
val
(every-1 pred (cdr xs))))))
(define (every-n pred xss)
(if (member '() xss)
#t
(let ((val (apply pred (map car xss)))
(yss (map cdr xss)))
(if (or (not val) (member '() yss))
val
(every-n pred yss)))))
(define every
(case-lambda
((pred xs)
(every-1 pred xs))
((pred xs . args)
(every-n pred (cons xs args)))))
(define (any-1 pred xs)
(if (null? xs)
#f
(or (pred (car xs))
(any-1 pred (cdr xs)))))
(define (any-n pred xss)
(if (member '() xss)
#f
(or (apply pred (map car xss))
(any-n pred (map cdr xss)))))
(define any
(case-lambda
((pred xs)
(any-1 pred xs))
((pred xs . args)
(any-n pred (cons xs args)))))
;; 線形探索
(define (find-if pred xs)
(let loop ((xs xs))
(cond
((null? xs) #f)
((pred (car xs)) (car xs))
(else
(find-if pred (cdr xs))))))
(define find
(case-lambda
((x xs)
(find-if (lambda (y) (eqv? x y)) xs))
((x xs pred)
(find-if (lambda (y) (pred x y)) xs))))
(define (position-if pred xs)
(let loop ((i 0) (xs xs))
(cond
((null? xs) #f)
((pred (car xs)) i)
(else
(loop (+ i 1) (cdr xs))))))
(define position
(case-lambda
((x xs)
(position-if (lambda (y) (eqv? x y)) xs))
((x xs pred)
(position-if (lambda (y) (pred x y)) xs))))
(define (count-if pred xs)
(let loop ((c 0) (xs xs))
(if (null? xs)
c
(loop (if (pred (car xs)) (+ c 1) c) (cdr xs)))))
(define count
(case-lambda
((x xs)
(count-if (lambda (y) (eqv? x y)) xs))
((x xs pred)
(count-if (lambda (y) (pred? x y)) xs))))
;; 重複要素があるか？
(define (duplicates? pred xs)
(cond
((null? xs) #f)
((member (car xs) (cdr xs) pred) #t)
(else
(duplicates? pred (cdr xs)))))
;; 重複要素を削除する
(define (remove-duplicates pred xs)
(let loop ((xs xs) (a '()))
(cond
((null? xs) (reverse! a))
((member (car xs) a pred)
(loop (cdr xs) a))
(else
(loop (cdr xs) (cons (car xs) a))))))
))