今回はちょっと便利な関数を問題形式で紹介します。元ネタは P-99: Ninety-Nine Prolog Problems です。問題は拙作のページ Prolog Programming Yet Anotehr Prolog Problems と同じですが、あしからずご了承くださいませ。
リストの要素がただひとつか調べる述語 single? を定義してください。
gosh> (single? '(a)) #t gosh> (single? '(a b)) #f gosh> (single? '()) #f
リストの要素が二つあるか調べる述語 double? を定義してください。
gosh> (double? '(a b)) #t gosh> (double? '(a b c)) #f gosh> (double? '(a)) #f
リスト xs はリスト ys よりも長いか調べる述語 longer? xs ys を定義してください。
gosh> (longer? '(a b c) '(a b)) #t gosh> (longer? '(a b) '(a b)) #f gosh> (longer? '(a) '(a b)) #f
リスト xs の最後尾を求める関数 last と、最後尾の要素を取り除く関数 butlast を定義してください。
gosh> (last '(a b c)) (c) gosh> (last '(a)) (a) gosh> (butlast '(a b c)) (a b) gosh> (butlast '(a)) ()
リスト xs の先頭から n 個の要素を取り出す関数 take xs n を定義してください。
gosh> (take '(a b c d e) 3) (a b c) gosh> (take '(a b c d e) 0) () gosh> (take '(a b c d e) 6) (a b c d e)
リスト xs の先頭から n 個の要素を取り除く関数 drop xs n を定義してください。
gosh> (drop '(a b c d e) 3) (d e) gosh> (drop '(a b c d e) 0) (a b c d e) gosh> (drop '(a b c d e) 6) ()
リスト xs の n 番目から m - 1 番目までの要素を部分リストとして取り出す関数 subseq xs n m を定義してください。なお、リストの要素は 0 から数え始めるものとします。
gosh> (subseq '(a b c d e) 2 4) (c d) gosh> (subseq '(a b c d e) 0 5) (a b c d e) gosh> (subseq '(a b c d e) 0 0) ()
リスト xs の末尾から n 個の要素を取り除く関数 butlastn xs n を定義してください。
gosh> (butlastn '(a b c d e) 3) (a b) gosh> (butlastn '(a b c d e) 0) (a b c d e) gosh> (butlastn '(a b c d e) 5) ()
リスト xs を長さ n の部分リストに分割する関数 group xs n を定義してください。
gosh> (group '(a b c d e f) 2) ((a b) (c d) (e f)) gosh> (group '(a b c d e f) 3) ((a b c) (d e f)) gosh> (group '(a b c d e f) 4) ((a b c d) (e f))
リスト ls の中から x と等しい要素の位置 n を求める関数 position x ls を定義してください。なお、リストの要素は 0 から数え始めるものとします。
gosh> (position 'a '(a b c d e)) 0 gosh> (position 'c '(a b c d e)) 2 gosh> (position 'e '(a b c d e)) 4 gosh> (position 'f '(a b c d e)) #f
リスト ls から x と等しい要素の個数 n を求める関数 count x ls を定義してください。
gosh> (count 'a '(a b a b c a b c d)) 3 gosh> (count 'c '(a b a b c a b c d)) 2 gosh> (count 'd '(a b a b c a b c d)) 1 gosh> (count 'e '(a b a b c a b c d)) 0
リストの要素の合計値を求める関数 sum-list を定義してください。
gosh> (sum-list '(1 2 3 4 5)) 15
リストの中から最大値を求める関数 max-list と最小値を求める関数 min-list を定義してください。
gosh> (max-list '(5 6 4 7 3 8 2 9 1)) 9 gosh> (min-list '(5 6 4 7 3 8 2 9 1)) 1
リスト ls の中で要素 x の右隣に要素 y があるかチェックする述語 adjacent? x y ls を定義してください。
gosh> (adjacent? 'a 'b '(a b c d e f)) #t gosh> (adjacent? 'e 'f '(a b c d e f)) #t gosh> (adjacent? 'f 'e '(a b c d e f)) #f
リスト ls の中で要素 x が 要素 y よりも前に出現しているか調べる述語 before? x y ls を定義してください。
gosh> (before? 'a 'b '(a b c d e f)) (b c d e f) gosh> (before? 'c 'b '(a b c d e f)) #f
整数 n から m までを格納したリストを作る関数 iota n m を定義してください。
gosh> (iota 1 5) (1 2 3 4 5)
リストから重複要素を取り除いて集合を生成する関数 set-of-list を定義してください。
gosh> (set-of-list '(a b c d e f a b c)) (d e f a b c)
2 つの集合の和を求める関数 union を定義してください。
gosh> (union '(a b c d) '(c d e f)) (a b c d e f)
2 つの集合の積を求める関数 intersection を定義してください。
gosh> (intersection '(a b c d) '(c d e f)) (c d)
2 つの集合の差を求める関数 difference を定義してください。
gosh> (difference '(a b c d) '(c d e f)) (a b)
2 つのソート済みのリストをひとつのソート済みのリストにまとめる関数 merge-list を定義してください。
gosh> (merge-list < '(1 3 5 7) '(2 4 6 8)) (1 2 3 4 5 6 7 8)
関数 merge-list を使ってリストをソートする merge-sort を定義してください。
gosh> (merge-sort < 9 '(5 6 4 7 8 3 2 9 1 10)) (1 2 3 4 5 6 7 8 9) gosh> (merge-sort < 10 '(5 6 4 7 8 3 2 9 1 10)) (1 2 3 4 5 6 7 8 9 10) gosh> (merge-sort < 11 '(5 6 4 7 8 3 2 9 1 10 0)) (0 1 2 3 4 5 6 7 8 9 10)
リスト ps がリスト ls の「接頭辞 (prefix) 」か判定する関数 prefix ls ps を定義してください。接頭辞とは、列の先頭からある位置までの部分列のことです。リスト [a, b, c, d] の接頭辞は [ ], [a], [a, b], [a, b, c], [a, b, c, d] の 5 つになります。
gosh> (prefix '(a b c d e f) '(a b c)) #t gosh> (prefix '(a b c d e f) '(a b c e)) #f gosh> (prefix '(a b c d e f) '()) #t
リスト ss がリスト ls の「接尾辞 (suffix) 」か判定する関数 suffix ls ss を定義してください。接尾辞とは、列のある位置から末尾までの部分列のことです。リスト [a, b, c, d] の接尾辞は [a, b, c, d], [b, c, d], [c, d], [d], [ ] の 5 つになります。
gosh> (suffix '(a b c d e f) '(d e f)) #t gosh> (suffix '(a b c d e f) '()) #t gosh> (suffix '(a b c d e f) '(f g)) #f
リスト xs がリスト ls の部分リストか判定する関数 sublist xs ls を定義してください。
gosh> (sublist '(c d e) '(a b c d e f)) #t gosh> (sublist '(d e) '(a b c d e f)) #t gosh> (sublist '(d e g) '(a b c d e f)) #f gosh> (sublist '() '(a b c d e f)) #t
リスト : 要素がただひとつか (define (single? ls) (and (pair? ls) (null? (cdr ls))))
Scheme の場合、引数 ls がリストで、かつ (cdr ls) が空リストであれば、そのリストの要素は一つしかないことがわかります。length でリストの長さを求める必要はありません。
リスト : 要素が二つあるか (define (double? ls) (and (pair? ls) (single? (cdr ls))))
Scheme の場合、述語 pair? が真であればリストに一つ以上の要素があることがわかります。あとは (cdr ls) が一つしか要素がないことを述語 single? で確認します。length でリストの長さを求める必要はありません。
リスト : リスト xs は ys よりも長いか
(define (longer? xs ys)
(cond ((null? xs) #f)
((null? ys) #t)
(else
(longer? (cdr xs) (cdr ys)))))
; 別解
(define (longer? xs ys)
(and (pair? xs)
(or (null? ys)
(longer? (cdr xs) (cdr ys)))))
リストの先頭から順番にたどり、途中で ys が空リストになれば ys の方が長いことがわかります。length でリストの長さを求めて比較するよりも、このプログラムの方が効率的だと思います。
リスト : リストの最後尾を求める
(define (last ls)
(if (null? (cdr ls))
ls
(last (cdr ls))))
関数 last は単純な再帰定義でリストの最後尾を求めています。Gauche には同じ働きをする関数 last-pair があります。
リスト : 最後尾の要素を取り除く
(define (butlast ls)
(if (single? ls)
'()
(cons (car ls) (butlast (cdr ls)))))
; 別解
(define (butlast ls)
(let loop ((ls ls) (a '()))
(if (single? ls)
(reverse! a)
(loop (cdr ls) (cons (car ls) a)))))
butlast は引数のリスト ls の要素が一つになるまで再帰呼び出しをします。要素が一つになったら空リストを返します。あとは、再帰呼び出しからの返り値に cons で要素を追加していくだけです。
別解は named let による末尾再帰バージョンです。累積変数 a に要素を格納し、引数 ls の要素がひとつになったならば、reverse! でリスト a を破壊的に反転して返します。reverse を使うよりも効率的です。
リスト : リストの先頭から n 個の要素を取り出す
(define (take ls n)
(if (or (<= n 0) (null? ls))
'()
(cons (car ls) (take (cdr ls) (- n 1)))))
; 別解
(define (take ls n)
(let loop ((ls ls) (n n) (a '()))
(if (or (<= n 0) (null? ls))
(reverse! a)
(loop (cdr ls) (- n 1) (cons (car ls) a)))))
引数 n が 0 以下または引数 ls が空リストの場合は空リストを返します。そうでなければ take を再帰呼び出しして、その返り値にリストの先頭要素 (car ls) を追加します。別解は named let による末尾再帰バージョンです。累積変数 a に要素を格納して、n が 0 以下または ls が空リストになったら、reverse! でリスト a を破壊的に反転して返します。
なお、take は Scheme のライブラリ SRFI-1 に用意されています。
リスト : リストの先頭から n 個の要素を削除する
(define (drop ls n)
(if (or (<= n 0) (null? ls))
ls
(drop (cdr ls) (- n 1))))
drop は簡単です。引数 n が 0 以下または引数 ls が空リストになるまで drop を再帰呼び出しするだけです。なお、drop は Scheme のライブラリ SRFI-1 に用意されています。
リスト : 部分リストを取り出す (define (subseq ls s e) (take (drop ls s) (- e s)))
subseq は drop と take を使うと簡単です。drop で ls から s 個の要素を取り除き、そのリストから e - s 個の要素を take で取り出すだけです。
リスト : リストの末尾から n 個の要素を取り除く (define (butlastn ls n) (take ls (- (length ls) n)))
リスト ls の長さを m とすると、リストの末尾から n 個の要素を取り除くことは、リストの先頭から m - n 個の要素を取り出すことと同じになります。取り出す要素の個数を (- (length ls) n)) で求めて take で要素を取り出します。
リスト : リストの分割
(define (group ls n)
(if (null? ls)
'()
(cons (take ls n) (group (drop ls n) n))))
; 別解
(define (group ls n)
(let loop ((ls ls) (a '()))
(if (null? ls)
(reverse! a)
(loop (drop ls n) (cons (take ls n) a)))))
関数 group は take と drop を使うと簡単に定義できます。ls が空リストの場合は分割できないので空リストを返します。これが再帰の停止条件になります。ls が空リストでない場合、まず take で n 個の要素を格納したリストを求めます。次に、n 個の要素を取り除いたリストを drop で求めて group を再帰呼び出しします。その返り値に take で取り出したリストを cons で追加すればいいわけです。
別解は named let による末尾再帰バージョンです。take で取り出したリストを累積変数 a に格納し、ls が空リストになったら reverse! でリスト a を破壊的に反転して返します。
リスト : 要素の位置を求める
(define (position x ls)
(let loop ((ls ls) (n 0))
(cond ((null? ls) #f)
((eqv? (car ls) x) n)
(else
(loop (cdr ls) (+ n 1))))))
named let の引数 n が要素の位置を表します。ls が空リストの場合、x と等しい要素は見つからなかったので #f を返します。そうでなければ、述語 eqv? でリストの先頭要素 (car ls) と x を比較します。等しい場合は n を返します。等しくない場合は loop を再帰呼び出しして次の要素を調べます。
リスト : 要素の個数を求める
(define (count x ls)
(let loop ((ls ls) (n 0))
(cond ((null? ls) n)
((eqv? (car ls) x) (loop (cdr ls) (+ n 1)))
(else (loop (cdr ls) n)))))
; 別解
(define (count x ls)
(fold (lambda (y n) (if (eqv? x y) (+ n 1) n)) 0 ls))
named let でリストの要素を順番に調べ、x と等しい要素が見つかれば累積変数 n の値を +1 します。別解は畳み込みを行う関数 fold を使ったバージョンです。fold は Gauche で定義されているものを使いました。
リスト : 要素の合計値を求める
(define (sum-list ls)
(let loop ((ls ls) (sum 0))
(if (null? ls)
sum
(loop (cdr ls) (+ (car ls) sum)))))
; 別解
(define (sum-list ls)
(fold (lambda (x sum) (+ x sum)) 0 ls))
sum-list は named let でリストの要素を累積変数 sum に加算するだけです。別解は畳み込みを行う関数 fold を使ったバージョンです。
リスト : リストから最大値と最小値を求める
(define (max-list ls)
(let loop ((ls (cdr ls)) (a (car ls)))
(cond ((null? ls) a)
((< a (car ls)) (loop (cdr ls) (car ls)))
(else (loop (cdr ls) a)))))
(define (min-list ls)
(let loop ((ls (cdr ls)) (a (car ls)))
(cond ((null? ls) a)
((> a (car ls)) (loop (cdr ls) (car ls)))
(else (loop (cdr ls) a)))))
; 別解
(define (max-list ls)
(fold (lambda (x a) (if (< a x) x a)) (car ls) (cdr ls)))
(define (min-list ls)
(fold (lambda (x a) (if (> a x) x a)) (car ls) (cdr ls)))
max_list と min_list は named let でプログラムしています。累積変数 a にリスト ls の先頭要素をセットします。あとは、残りの要素を順番に調べ、a よりも大きい (小さい) 要素を見つけたら、その値を a にセットします。別解は fold を使ったバージョンです。
リスト : x と y は隣り合っているか
(define (adjacent x y ls)
(if (and (pair? ls) (pair? (cdr ls)))
(if (and (eqv? (car ls) x) (eqv? (cadr ls) y))
#t
(adjacent x y (cdr ls)))
#f))
; 別解
(define (adjacent x y ls)
(let ((xs (memv x ls)))
(if xs
(if (eqv? (cadr xs) y)
#t
(adjacent x y (cdr xs)))
#f)))
最初にリストの要素が二つ以上あることをチェックします。次に、先頭の要素が x と等しくて、次の要素が y と等しいことをチェックします。そうであれば #t を返し、そうでなければ adjacent を再帰呼び出しして、次の要素を調べます。別解は関数 memv を使ったバージョンです。
リスト : x は y よりも前に出現しているか
(define (before x y ls)
(let ((xs (memv x ls)))
(if xs
(memv y (cdr xs))
#f)))
関数 before は関数 memv を使うと簡単にプログラムすることができます。ls から x を memv で探します。x を見つけた場合、xs の先頭要素は x になります。それを取り除いたリストから memv で y を探せばいいわけです。
リスト : 数列の生成
(define (iota n m)
(if (> n m)
'()
(cons n (iota (+ n 1) m))))
; 別解
(define (iota n m)
(let loop ((m m) (a '()))
(if (< m n)
a
(loop (- m 1) (cons m a)))))
関数 iota は簡単です。n が m より大きい場合は空リストになります。n が m 以下の場合、iota を再帰呼び出しして n + 1 から m までのリストを生成し、その先頭に n を追加するだけです。別解は named let を使ったバージョンです。この場合、後ろから数値を生成していることに注意してください。m が n よりも小さくなったならばリスト a を返します。
リスト : 集合の生成
(define (set-of-list ls)
(cond ((null? ls) '())
((memv (car ls) (cdr ls))
(set-of-list (cdr ls)))
(else
(cons (car ls) (set-of-list (cdr ls))))))
; 別解
(define (set-of-list ls)
(let loop ((ls ls) (a '()))
(cond ((null? ls) (reverse! a))
((memv (car ls) (cdr ls))
(loop (cdr ls) a))
(else
(loop (cdr ls) (cons (car ls) a))))))
述語 set-of-list はリストから重複要素を取り除きます。空リストは重複要素がないので空リストのままです。次の節で、リストの先頭要素 (car ls) が残りのリスト (cdr ls) にあるか memv で調べ、同じ要素があれば集合に加えません。else 節で同じ要素がない場合はそれを集合に加えます。別解は named let を使った末尾再帰バージョンです。
リスト : 集合の和
(define (union xs ys)
(cond ((null? xs) ys)
((memv (car xs) ys)
(union (cdr xs) ys))
(else
(cons (car xs) (union (cdr xs) ys)))))
; 別解 1
(define (union xs ys)
(let loop ((xs xs) (a ys))
(cond ((null? xs) a)
((memv (car xs) ys)
(loop (cdr xs) a))
(else
(loop (cdr xs) (cons (car xs) a))))))
; 別解 2
(define (union xs ys)
(fold (lambda (x a) (if (memv x ys) a (cons x a))) ys xs))
最初の節は空集合 (空リスト) と集合 ys の和は ys であることを表しています。次の節で、要素 (car xs) が集合 ys に含まれていれば、それを新しい集合に加えません。else 節で (car xs) が ys に含まれていなければ、それを集合に追加します。別解は named let と fold を使ったバージョンです。
リスト : 集合の積
(define (intersection xs ys)
(cond ((null? xs) '())
((memv (car xs) ys)
(cons (car xs) (intersection (cdr xs) ys)))
(else
(intersection (cdr xs) ys))))
; 別解 1
(define (intersection xs ys)
(let loop ((xs xs) (a '()))
(cond ((null? xs) a)
((memv (car xs) ys)
(loop (cdr xs) (cons (car xs) a)))
(else
(loop (cdr xs) a)))))
; 別解 2
(define (intersection xs ys)
(fold (lambda (x a) (if (memv x ys) (cons x a) a)) '() xs))
最初の節は空集合 (空リスト) と集合 ys の積は空集合であることを表しています。次の節で、要素 (car xs) が集合 ys に含まれていれば、それを新しい集合に追加します。そうでなければ、else 節で要素 (car xs) を集合に追加しません。別解は named let と fold を使ったバージョンです。
リスト : 集合の差
(define (difference xs ys)
(cond ((null? xs) '())
((memv (car xs) ys)
(difference (cdr xs) ys))
(else
(cons (car xs) (difference (cdr xs) ys)))))
; 別解 1
(define (difference xs ys)
(let loop ((xs xs) (a '()))
(cond ((null? xs) a)
((memv (car xs) ys)
(loop (cdr xs) a))
(else
(loop (cdr xs) (cons (car xs) a))))))
; 別解 2
(define (difference xs ys)
(fold (lambda (x a) (if (memv x ys) a (cons x a))) '() xs))
最初の節は、空集合と集合 ys の差は空集合であることを表しています。次の節で、要素 (car xs) が ys に含まれいる場合は集合にそれを追加しません。そうでなければ、else 節で要素 (car xs) を集合に追加します。別解は named let と fold を使ったバージョンです。
リスト : リストのマージ
(define (merge-list pred xs ys)
(cond ((null? xs) ys)
((null? ys) xs)
((pred (car xs) (car ys))
(cons (car xs) (merge-list pred (cdr xs) ys)))
(else
(cons (car ys) (merge-list pred xs (cdr ys))))))
最初の節は、空リストとリスト ys をマージすると ys になることを表しています。次の節は、リスト xs と空リストをマージすると xs になることを表しています。この 2 つの節が、再帰呼び出しの停止条件になります。
3 番目の節で、それぞれのリストの先頭要素を述語 pred で比較し、pred が真を返す場合は (car xs) をマージしたリストの先頭に追加し、そうでなければ最後の節で (car ys) をマージしたリストの先頭に追加します。merge-list を再帰呼び出しするときは、xs または ys の先頭要素を取り除いて呼び出すことに注意してください。
マージソートはリストの長さを 1, 2, 4, 8, ... と増やしていくよりも、再帰的に考えた方が簡単です。まず、ソートするリストを 2 つに分割して、前半部分をソートします。次に、後半部分をソートして、その結果をマージすればいいわけです。
再帰呼び出しするたびにリストは 2 つに分割されるので、最後にリストの要素はひとつとなります。これはソート済みのリストなので、ここで再帰呼び出しを終了してマージ処理を行えばいいわけです。プログラムは次のようになります。
リスト : マージソート
(define (merge-sort pred n ls)
(if (= n 1)
(list (car ls))
(let ((m (quotient n 2)))
(merge-list
pred
(merge-sort pred m ls)
(merge-sort pred (- n m) (drop ls m))))))
関数 merge-sort の引数 pred が要素を比較する述語、引数 ls がソートするリスト、引数 n がリストの長さを表します。merge-sort はリストを分割する処理で、新しいリストを作らないことに注意してください。merge-sort はソートするリストの範囲を開始位置と長さで表しています。リストを二分割する場合、前半部分は ls と m (= n / 2) で表し、後半部分を (drop ls m) と (- n m) で表します。
あとは merge-sort を再帰呼び出しでリストを分割していき、リストの長さが 1 になったならば新しいリストを返します。そして、merge-sort でソートしたリストを merge-list でマージすればいいわけです。
リスト : 接頭辞の判定
(define (prefix ls ps)
(cond ((null? ps) #t)
((eqv? (car ls) (car ps))
(prefix (cdr ls) (cdr ps)))
(else #f)))
接頭辞の判定は簡単です。最初の節は、空リストは接頭辞であることを表しています。次の節で、リストの先頭要素が等しい場合は、残りのリスト (cdr ps) が (cdr ls) の接頭辞であることを確かめます。
リスト : 接尾辞の判定 (define (suffix ls ss) (prefix (drop ls (- (length ls) (length ss))) ss))
接尾辞の判定も簡単です。リスト ls と ss の長さの差分を求め、ls の先頭から差分の個数だけ要素を取り除きます。これで ls と ss の長さが等しくなるので、あとは prefix で比較するだけです。
リスト : 部分リストの判定
(define (sublist ks ls)
(cond ((null? ls) #f)
((prefix ls ks) #t)
(else (sublist ks (cdr ls)))))
sublist は prefix を使うと簡単です。最初の節で ls が空リストの場合、ks は部分リストではないので #f を返します。次の節で、ks が ls の接頭辞であれば部分リストなので #t を返します。それ以外の場合は ls の先頭要素を取り除いて、sublist を再帰呼び出しするだけです。