枝刈りをしながら組み合わせを求めたい。つまり、似たような要素を同一視して、集合の総数を絞りながら組み合わせを求めていきたい。
ふつうなら集合をユニークな要素だけで構成しなおしてから組み合わせを求めればいいんだけど、「ユニーク」の意味によってはそれができない場合もある。
たとえばベクトルからなる集合で、「いずれかの項が同じであれば同一視」のような場合。次のような2次元ベクトルからなる集合Aがあるとして、
A = {(1, 2) (2, 3) (3, 4) (4, 5) (5, 6) (6, 7)}集合Aからすべての項が異なる3つのベクトルを取り出す組み合わせは、
{(1, 2) (3, 4) (5, 6)},
{(1, 2) (3, 4) (6, 7)},
{(1, 2) (4, 5) (6, 7)},
{(2, 3) (4, 5) (6, 7)} の4つになるだろう。この4つを求めるのに、すべての3要素の組み合わせを求めてから相異なる要素で構成されているものを取り出していると、集合が大きくなるにつれ厄介なことになるのが目に見えている。かといって、集合Aをあらかじめユニークな要素だけで再構成することもできない。
まず、ふつうの組み合わせを求める combinations プロシージャを次のような戦略で考える。
集合をリスト ls とみなし、その要素から n 個の組み合わせをすべて求めるプロシージャ (noraml-combinations ls n) を、次の 1.と 2.の append として作る。
- (car ls) と (noraml-combinations (cdr ls) (- n 1)) の cons
- (normal-combinations (cdr ls) n)
1.から「(car ls) を先頭の要素に持つ組み合わせ」がすべて得られ、2.で同様の操作をリスト全体にわたって行うつもり。ザ・リストの再帰処理。
(define (normal-combinations ls n)
(cond ((> n (length ls))
'())
((= n 1)
(map list ls))
((> n (+ 1 (length (cdr ls))))
(list ls))
(else
(append
(map (lambda (x) (cons (car ls) x))
(normal-combinations (cdr ls) (- n 1)))
(normal-combinations (cdr ls) n)))))
境界条件がなんか複雑で、本当にこれであってるのかよくわからないのはここだけの話。まあ、とりあえず意図通りの結果にはなるみたい。
gosh> test-set
((1 2) (2 3) (3 4) (4 5) (5 6) (6 7))
gosh> (normal-combinations test-set 3)
((#0=(1 2) #1=(2 3) #2=(3 4)) (#0# #1# #3=(4 5)) (#0# #1# #4=(5 6))
(#0# #1# #5=(6 7)) (#0# #2# #3#) (#0# #2# #4#) (#0# #2# #5#)
(#0# #3# #4#) (#0# #3# #5#) (#0# #4# #5#) (#1# #2# #3#)
(#1# #2# #4#) (#1# #2# #5#) (#1# #3# #4#) (#1# #3# #5#)
(#1# #4# #5#) (#2# #3# #4#) (#2# #3# #5#) (#2# #4# #5#)
(#3# #4# #5#))
枝刈りしながら組み合わせを求めるという本題を達成するには、枝刈りプロシージャ proc を渡して、1.の操作の cdr を proc に変えればいいだろう（2.の部分の cdr はリストの再帰的な操作のためのものなので、proc に変える必要はない）。
(define (trim-combinations ls n proc)
(cond ((> n (length ls))
'())
((= n 1)
(map list ls))
((> (- n 1) (length (proc ls)))
(trim-combinations (cdr ls) n proc))
(else
(append
(map (lambda (x) (cons (car ls) x))
(trim-combinations (proc ls) (- n 1) proc))
(trim-combinations (cdr ls) n proc)))))
枝刈りプロシージャとしては、ベクトルが相異なることを表現する distinct? と、リストとして表した集合から car と相異なる cdr を導く distinct-cdr 用意する。gauche の lset-union は、(use srfi-1) が必要だね。
(define (distinct? v1 v2)
(= (length (lset-union eq? v1 v2))
(+ (length v1) (length v2))))
(define (distinct-cdr ls)
(let R ((tail (cdr ls)))
(cond ((null? tail) '())
((not (distinct? (car ls) (car tail)))
(R (cdr tail)))
(else
(cons (car tail) (R (cdr tail)))))))
実行結果。
gosh> (trim-combinations test-set 3 distinct-cdr)
((#0=(1 2) #1=(3 4) (5 6)) (#0# #1# #2=(6 7)) (#0# #3=(4 5) #2#) ((2 3) #3# #2#))
しかしアレだな。lengthとか使いすぎなので、あまり効率よくないんじゃないか、これ。
