中西式置換プログラム

前回のブログ(2009年8月27日中西流置換プログラム)の最後に書いたTAOCPのアルゴリズム7.2.1.2-Lは, Lというだけあって辞書式順(lexicographicalorder)で, n項の置換, 例えば(1 2 2 3)の置換

((1 2 2 3) (1 2 3 2) (1 3 2 2) (2 1 2 3) (2 1 3 2) (2 2 1 3)
(2 2 3 1) (2 3 1 2) (2 3 2 1) (3 1 2 2) (3 2 1 2) (3 2 2 1))

を作る. 辞書式順とは, 配列の左端に小数点があるとして, 数値順にソートするものである.

(0 1 2 3)の中西ソートの結果

(perm '(0 1 2 3)) =>
((0 1 2 3) (1 0 2 3) (1 2 0 3) (1 2 3 0) (0 2 1 3) (2 0 1 3)
(2 1 0 3) (2 1 3 0) (0 2 3 1) (2 0 3 1) (2 3 0 1) (2 3 1 0)
(0 1 3 2) (1 0 3 2) (1 3 0 2) (1 3 2 0) (0 3 1 2) (3 0 1 2)
(3 1 0 2) (3 1 2 0) (0 3 2 1) (3 0 2 1) (3 2 0 1) (3 2 1 0))

を

(define (dec s)
(string->number (string-append "."
(apply string-append (map number->string s)))))

で小数にする.

(dec '(0 1 2 3)) => .0123

先ほどの置換を小数にしてソートすると

(sort (map dec (perm '(0 1 2 3))) <) =>
(.0123 .0132 .0213 .0231 .0312 .0321 .1023 .1032 .1203 .123
.1302 .132 .2013 .2031 .2103 .213 .2301 .231 .3012 .3021
.3102 .312 .3201 .321)

アルゴリズムLの結果の辞書式順

 
                                                                    
(algorithm7212l '(0 1 2 3))=>
((0 1 2 3) (0 1 3 2) (0 2 1 3) (0 2 3 1) (0 3 1 2) (0 3 2 1)
(1 0 2 3) (1 0 3 2) (1 2 0 3) (1 2 3 0) (1 3 0 2) (1 3 2 0)
(2 0 1 3) (2 0 3 1) (2 1 0 3) (2 1 3 0) (2 3 0 1) (2 3 1 0)
(3 0 1 2) (3 0 2 1) (3 1 0 2) (3 1 2 0) (3 2 0 1) (3 2 1 0))

になる. いまはどれも4桁なので, 小数ではなく, 整数と思ってソートするのでもよい.

私のブログの2008年10月28日のに, 切頭八面体の絵があり, {0,1,2,3}の全順列を, 隣り同士の交換で実現したと書いてある. 隣り同士の交換で, 全順列を作るのを, 英語ではPlain Changeという.

下の図がその1例である. 左の24段が, {0,1,2,3}の置換で, x印のところが隣り同士交換した場所である. 一番下のx印の交換をすると, 一番上に戻る.

右上の6段は, 左で0を挿入される{1,2,3}の置換である. これも同じように出来ている.

赤線は0の移動を示す.




x印が連続するように, 中西アルゴリズムを少し修正すると,plain changeのアルゴリズムになる. 前回のプログラムのappendを1つおきに逆にappendするようにすればよい. それが下のrevap (reverse appendのつもり)

(revap '(0 1) '(2 3) '(4 5) '(6 7)) => (0 1 3 2 4 5 7 6)

これを使うとplain changeが出来る.

(define (plainchange ls)
(define (revap . ls)
 (cond ((null? ls) '())
       ((null? (cdr ls)) (car ls))
        (else (append (car ls) (reverse (cadr ls))
         (apply revap (cddr ls))))))
(define (ins h tl)
 (if (null? tl) (list (list h))
  (cons (cons h tl)
(map (lambda (l) (cons (car tl) l)) (ins h (cdr tl))))))
 (if (null? ls) (list '())
  (apply revap (map (lambda (l) (ins (car ls) l))
   (plainchange (cdr ls))))))

(plainchange '(0 1 2 3))の結果を切頭八面体のHamiltonian閉路にしたのが



である.

中西式置換プログラム

置換(順列)を計算するプログラムにもいろいろな流儀がある. あるとき中西流(と私が勝手に呼んでいる)というのを知った.

(2000年に身罷った中西正和君について, 私が以前, 「数式処理」に寄稿したものを, googleでサーチしていて, 偶然見つけた.)

中西君のプログラムは, むかし風にM式で書いてあり,

perm[x]
=[null [cdr [x]] -> list [x] ;
t -> mapcon [perm [cdr [x]];
quote [lambda [[y]; insert [nil; car [x]; car [y]]]]
  ]]
;
insert [x; a; y]
= [null [y] -> list [append [x; cons[a;y]]] ;
t -> cons [append [x; cons [a; y]];
  insert [nconc [x; list [car [y]]]; a; cdr [y]]
  ]]

いま風に書けば (近年はMS変換の出来る人も少ないに違いない.)

(define (perm x)
(if (null? (cdr x)) (list x)
   (mapcon (perm (cdr x))
    (lambda (y) (insert '() (car x) (car y))) )))

(define (insert x a y)
(if (null? y) (list (append x (cons a y)))
 (cons (append x (cons a y))
   (insert (append x (list (car y))) a (cdr y)))))

mapconも定義する.

(define (mapcon x f)
(if (null? x) '()
 (append (f x) (mapcon (cdr x) f))))

insertは以下のような関数である.

(insert '() 'a '(b c)) => ((a b c) (b a c) (b c a))

これを下請けにして, permは

(perm '(a b c)) =>
((a b c) (b a c) (b c a) (a c b) (c a b) (c b a))

これでもいいのだが, mapconやnconcが気に入らず, わたし風に中西流を書いてみた.

(define (perm ls)
(define (ins h tl)
(if (null? tl) (list (list h))
(cons (cons h tl)
 (map (lambda (l) (cons (car tl) l)) (ins h (cdr tl))))))
(if (null? ls) (list '())
(apply append (map (lambda (l) (ins (car ls) l))
(perm (cdr ls))))))

入れ子で定義してあるinsを見てみる. 働きは中西insertと同じである.

(define (ins h tl)
(if (null? tl) (list (list h))
(cons (cons h tl)
(map (lambda (l) (cons (car tl) l)) (ins h (cdr tl))))))

(ins 'a '(b c d)) =>
((a b c d) (b a c d) (b c a d) (b c d a))

3行目の(cons h tl)は, 完成したリストの先頭を作る, つまり(a b c d)を作って, 後から出来てきたリスト((b a c d) (b c a d) (b c d a))にconsする.

後のリストの作り方は, (ins h (cdr tl))が, (cdr tl)つまり(c d)に, hつまりaをinsしたもの, ((a c d) (c a d) (c d a))のそれぞれに, (car lt)つまりbをconsして作る. mapを使う.

tlがnilだったら, ((a))を返す. (list (list h))

(define (perm ls)
(if (null? ls) (list '())
(apply append (map (lambda (l) (ins (car ls) l))
(perm (cdr ls))))))

lsがnilの場合は後回しにして, lsが(a b c d)だったとする. 最後の方の(perm (cdr ls))により, (b c d)のperm, ((b c d) (c b d) (c d b) (b d c) (d b c) (d c b))が出来るわけで, このそれぞれにaをinsし, それを最後にappendする.

lsが段々短くなり, (d)だけになったときを考える. insでつけるのはd, つけられるリストは()で, そのときは, ()のpermで(())が返り, ((d))が出来る.

それにcをinsするから, ((c d) (d c))が出来る.

このようにしてpermが作れた.

ついでだが, TAOCPのアルゴリズム7.2.1.2-LのScheme版は以下の通り.

(define (algorithm7212l as)    ;TAOCP V4F2 p.39
 (define (interchange ls a b)
  (define (list-set! ls n a)
   (set-car! (list-tail ls n) a))
  (let ((t (list-ref ls a)))
   (list-set! ls a (list-ref ls b))
   (list-set! ls b t)))
 (let ((n 3) (j 0) (k 0) (l 0) (ps '()))
  (define (l1) (set! ps (cons (tree-copy as) ps)) (l2))
  (define (l2)
   (set! j (do ((j (- n 1) (- j 1)))
    ((or (< j 0) (< (list-ref as j) (list-ref as (+ j 1))))
      j)))
   (if (>= j 0)(l3) (reverse ps)))
 (define (l3)
  (set! l (do ((l n (- l 1)))
   ((< (list-ref as j) (list-ref as l)) l)))
  (interchange as j l) (l4))
 (define (l4)
  (define (loop)
   (if (< k l)
    (begin (interchange as k l) (set! k (+ k 1))
     (set! l (- l 1)) (loop))))
  (set! k (+ j 1)) (set! l n) (loop) (l1))
 (l1)))