順列を求めるプログラム（Perl、Elisp）

"Higher-Order Perl" という本を読む。順列を求めるプログラムが載っている。何かの役にたつかもしれないから覚えとこう、と思い実際に書いてみる。ついでにEmacs Lispでも書いてみる。

Perlで順列（permutation）を求める

Higher-Order Perl: - Google ブックス より、そのまま引用。

sub permute{
  my @items = @{ $_[0] };
  my @perms = @{ $_[1] };
  unless(@items){
    print "@perms\n";
  } else {
    my(@newitems, @newperms, $i);
    foreach $i (0 .. $#items) {
      @newitems = @items;
      @newperms = @perms;
      unshift(@newperms, splice(@newitems, $i, 1));
      permute([@newitems], [@newperms]);
    }
  }
}
# sample call:
permute([qw(red yellow blue green)], []);

"permute.pl"というファイルに保存し、実行してみる。

$ perl ./permute.pl
green blue yellow red
blue green yellow red
green yellow blue red
yellow green blue red
blue yellow green red
yellow blue green red
green blue red yellow
blue green red yellow
green red blue yellow
red green blue yellow
blue red green yellow
red blue green yellow
green yellow red blue
yellow green red blue
green red yellow blue
red green yellow blue
yellow red green blue
red yellow green blue
blue yellow red green
yellow blue red green
blue red yellow green
red blue yellow green
yellow red blue green
red yellow blue green

順序が反対になって出力されるのが気になるが（red yellow blue green が最初に出力されて欲しい）、これはunshiftをpushに変えれば済む話なのでよしとする。

Emacs Lispの場合

loopは使わずに、マップ関数で実現。

(defun permute (lat)
  (cond
   ((null lat) '(()))
   (t (mapcan
       (lambda (atm)
         (mapcar (lambda (lst) (cons atm lst))
                 (permute (remove* atm lat :count 1))))
       lat))))

Perlよりだいぶすっきり。しかし一つひとつの関数が濃い。

実行結果。

(permute '(red yellow blue green))
=> ((red yellow blue green) (red yellow green blue)
    (red blue yellow green) (red blue green yellow)
    (red green yellow blue) (red green blue yellow)
    (yellow red blue green) (yellow red green blue)
    (yellow blue red green) (yellow blue green red)
    (yellow green red blue) (yellow green blue red)
    (blue red yellow green) (blue red green yellow)
    (blue yellow red green) (blue yellow green red)
    (blue green red yellow) (blue green yellow red)
    (green red yellow blue) (green red blue yellow)
    (green yellow red blue) (green yellow blue red)
    (green blue red yellow) (green blue yellow red))

導出について

上記の関数を作るときの考え方を書いておく。

まず、具体的な計算例を想像して分析してみる。たとえば3要素のリスト (a b c) に対して期待される結果は ((a b c) (a c b) (b a c) (b c a) (c a b) (c b a)) となる。

このうち、最初の2つの部分リスト ((a b c) (a c b)) は、 a を リスト (b c) と (c b) に cons した形なので次式で表せる。

(mapcar (lambda (lst) (cons 'a lst)) '((b c) (c b)))

さらに、第二引数の((b c) (c b))は、(b c)の順列だから、(permute '(b c))と表せる。

(mapcar (lambda (lst) (cons 'a lst)) (permute '(b c)))

残り4つの部分リストも同様に(mapcar (lambda ...) (permute ...))の形で表し、これらを連結（nconc）する。

(nconc
 (mapcar (lambda (lst) (cons 'a lst)) (permute '(b c)))
 (mapcar (lambda (lst) (cons 'b lst)) (permute '(a c)))
 (mapcar (lambda (lst) (cons 'c lst)) (permute '(a b))))

同じようなコードの重複を無くすため、mapcanを使って変形する。

(mapcan
 (lambda (atm)
   (mapcar (lambda (lst) (cons atm lst))
           (permute (remove* atm '(a b c) :count 1))))
 '(a b c))

remove*は第1引数と等しい要素を第2引数からすべて削除する関数だが、キーワードパラメータとして :count 1 を指定すれば削除する個数を制限できる。

この段階で再帰的関数の主要部分ができたので、(a b c)を関数の引数 lat として defun に変換する。

(defun permute (lat)
  (cond
   ((null lat) ???)
   (t (mapcan
       (lambda (atm)
         (mapcar (lambda (lst) (cons atm lst))
                 (permute (remove* atm lat :count 1))))
       lat))))

あとは保留してある「???」の部分、すなわち再帰が終了する場合の式を考えれば完成。

そのため、要素1個のリスト (a) の順列を求める過程を具体的にトレースしてみる。

(permute '(a))
;; cond の t に対応する式
=> (mapcan
    (lambda (atm)
      (mapcar (lambda (lst) (cons atm lst))
              (permute (remove* atm '(a) :count 1))))
    '(a))
;; mapcan を評価して、atm を 'a に置換
=> (nconc
    (mapcar (lambda (lst) (cons 'a lst))
            (permute (remove* 'a '(a) :count 1))))
;; remove* と nconc を評価（引数が1個なので nconc は実質的に何もしない）
=> (mapcar (lambda (lst) (cons 'a lst))
            (permute nil))

ここまで展開すると、(a)の順列を求めた結果が ((a)) となるためには(permute nil) の結果が (()) であればよいということがきっと分かる。

(mapcar (lambda (lst) (cons 'a lst))
            '(()))
=> ((a))

よって、保留した部分も '(()) と書けばよい。これでようやく関数が完成。

(defun permute (lat)
  (cond
   ((null lat) '(()))
   (t (mapcan
       (lambda (atm)
         (mapcar (lambda (lst) (cons atm lst))
                 (permute (remove* atm lat :count 1))))
       lat))))

参考

• Higher-Order Perl: - Google ブックス