TAOCP の順列アルゴリズムで一番初めに紹介されているアルゴリズムを実装した。
ソート済みされた整数列について、辞書順に組み合わせを生成していくアルゴリズムを実装したい。
(1 2 2 3) という列について, 辞書順に組み合わせていく。 ただし、実際の実装では組み合わせがもとまったら、結果のリストと cons するため、 結果は辞書順の逆になってしまう。
((3 2 2 1) (3 2 1 2) (3 1 2 2) (2 3 2 1) (2 3 1 2) (2 2 3 1) (2 2 1 3)
(2 1 3 2) (2 1 2 3) (1 3 2 2) (1 2 3 2) (1 2 2 3))
どういうアルゴリズムなのか、実際に 2 3 2 1 から 3 1 2 2 を生成してみよう。
2 3 2 1 で ソート順が保たれている連続しているペアを数列の後ろから探す。
2 3 2 1
^ ^ -> 2 > 1 なので次
2 3 2 1
^ ^ -> 3 > 2 なので次
2 3 2 1
^ ^ -> 2 < 3 なので 2 の添え字 0 を j とする
次に a_j = 2 と, 数列の後ろから比較してソート順となる要素を探す
2 3 2 1
^ ^
2 3 2 1
^ ^
2 3 2 1
^ ^ -> 2 < 3 なので 3 の添え字 1 を l とする
そして a_j と a_l を入れ替える。
ただこの入れ替えだけでは不十分な場合, たとえば 1 3 2 2 から 2 1 2 3 の場合がある。
1 3 2 2 から 1 と 2 を入れ替え 2 3 2 1 を得る。
後ろの 3 2 1 はソートされていないので, 3 と 1 を入れ替える必要がある。
アルゴリズムを考えると j と l が決まった時点で,
j から n まではソート順どおりに並んでいて, l+1 から n までは逆順となっているはずだ
j j+1 j+2 … l-2 l-1 l l+1 … n
ここで j と l を入れ替えると j+1 から l-1 の間
一般的に、考え方としては、辞書順である整数列の直後にくる整数列というのは
- TODO
ということ。
まず find-constant で入れ替えるべき
(defun find-constant (set)
(labels ((f (j)
(cond ((< j 0) -1)
((< (nth j set)
(nth (1+ j) set)) j)
(t (f (1- j)))))
(g (j l)
(if (< (nth j set)
(nth l set))
l
(g j (1- l)))))
(let ((j (f (- (length set) 2))))
(if (< j 0)
nil
(cons j
(g j (1- (length set))))))))
この関数で入れ替える部分列を求めている。
;; taken from taocp 7.2.1.2
(defun algorithm-l (set)
(let ((result) (p))
(loop
do
;; Step 1
(setf result (cons (mapcar #'identity set) result))
;; Step 2 and 3
(setf p (find-constant set))
(when (null p)
(return))
;; Step 3
(rotatef (nth (car p) set)
(nth (cdr p) set))
;; Step 4
(loop
with k = (1+ (car p))
with l = (1- (length set))
while (< k l)
do
(rotatef (nth k set)
(nth l set))
(incf k)
(decf l)))
result))
実装1回目 (失敗)
TAOCP のアルゴリズムを実装してみたけど、 うまくいかないので、どっかミスってるはず。 エラッタにも載っていない。
リストの要素数が4つの時はうまく停止するが、それより多いとダメっぽい。 アルゴリズムを詳しく見て、実装を確かめよう。
;; from TAOCP 7.2.1.2 Algorithm L
;; An auxiliary element (nth 0 an) is to be present for
;; convenience; the element must be strictly less than
;; the largest element an.
(defparameter l '(0 1 2 3 4 5))
(algorithm-l l)
(defun algorithm-l (an &optional (predicate #'>=))
(let ((n (- (length an) 1)) (j 0) (l 0) (k 0))
(tagbody
l1 ;; Visit
(print an)
l2 ;; Find j
(setf j (- n 1))
l2-1
(if (funcall predicate
(nth j an) (nth (+ j 1) an))
(decf j)
(go l3))
(when (= j 0)
(go end))
(go l2-1)
l3 ;; Increase aj
(setf l n)
l3-1
(if (funcall predicate
(nth j an) (nth l an))
(decf l)
(go l3-2))
l3-2
(progn
(rotatef (nth j an) (nth l an))
(format t "interchange a~a with a~a~%" j l))
(go l4)
l4 ;; Reverse a(j+1) ... an
(setf k (+ j 1) l n)
l4-1
(when (< k l)
(rotatef (nth k an) (nth l an))
(incf k)
(decf l))
(go l1)
end
(print 'end))))