https://twitter.com/_marony/status/626654108947083266 のお題を拾いました。
巡回を使うヴァージョン
import Data.List (intersperse)
permutate :: [a] -> [[a]]
permutate [] = [[]]
permutate (x:xs) = concat $ map circulate $ map (x:) $ permutate xs
circulate :: [a] -> [[a]] -- リストを巡回させたものを列挙する関数
circulate xs = take n $ map (take n) $ iterate tail $ cycle xs where n = length xs
-- 明示的な再帰を書かずに済ませられるようにfoldrで書き換えたのが以下のもの
-- でも、permutateはどう考えても普通に再帰で書いたほうがわかりやすいと思います
-- circulateはlengthを使わずに無限リストを扱えるようにしてみました
{-
permutate :: [a] -> [[a]]
permutate xs = foldr (\x -> concatMap (circulate . (x:))) [[]] xs
circulate :: [a] -> [[a]]
circulate xs = take' $ map take' $ iterate tail $ cycle xs
where take' = zipWith (flip const) xs
-}
main = mapM_ (putStrLn . intersperse ' ') (permutate "12345")
どう考えるか
素直な再帰で書くには、permutate (x:xs)をpermutate xsから作り上げたい。自明でない再帰を書くときにはまずn=4くらいで具体的に考えてみるのが個人的な方針。そこで、[a,b,c,d]の順列(permutate [a,b,c,d])を[b,c,d]の順列(permutate [b,c,d])を加工して作ることを考える。
まず [b,c,d] の順列
[b,c,d]
[b,d,c]
[c,b,d]
[c,d,b]
[d,b,c]
[d,c,b]
を考える（個数は3!）。
これらの頭にaをくっつければ[a,b,c,d]の順列のうちで頭がaであるような3!個の相異なった要素が得られる。つまり
[a,b,c,d]
[a,b,d,c]
[a,c,b,d]
[a,c,d,b]
[a,d,b,c]
[a,d,c,b]
になる。
更にこれらのそれぞれを、たとえば[a,b,c,d] ⇒ [a,b,c,d][b,c,d,a][c,d,a,b][d,a,b,c]といったように巡回(circulate [a,b,c,d])させてやれば、相異なった4*3!=4!個の順列が得られ、これは4要素のリストの順列の総数(4!)だから必要な順列は全部列挙されていることがわかる。
最後にこれらをconcatしてリストを1段階潰せば型が揃う。
この発想を一般化して再帰で書けばご覧のとおり。
permutate [] = [[]]
permutate (x:xs) = concat $ map circulate $ map (x:) $ permutate xs
置換に関する数学的事実を利用すればもっとシンプルで効率的に書ける気がするけれどもひと目で思いついたのはこれ。
ちなみにcirculateの定義
circulate xs = take n $ map (take n) $ iterate tail $ cycle xs where n = length xs
の仕組みは
cycle [a,b,c,d] ⇒
[a,b,c,d,a,b,c,d,...]
iterate tail (cycle [a,b,c,d]) ⇒
[a,b,c,d,a,b,c,d,...]
[b,c,d,a,b,c,d,a,...]
[c,d,a,b,c,d,a,b,...]
[d,a,b,c,d,a,b,c,...]
[a,b,c,d,a,b,c,d,...]
...
...
take 4 . map (take 4) ⇒
[a,b,c,d]
[b,c,d,a]
[c,d,a,b]
[d,a,b,c]
というものです。
順列を頭から構成していくヴァージョン（結果は辞書順）
import Data.List (delete)
permutate :: [a] -> [[a]]
permutate [] = [[]]
permutate xs = concatMap (\x -> map (x:) (permutate (delete x xs))) xs
集合[a,b,c,d]の順列を数え上げる際の普通の考え方は、最初の要素は[a,b,c,d]の4通り、次の要素は最初の要素を除いた3通り、次の要素は前2つを除いた2通り、というもののはず。この発想を採用して順列を構成しようとするとどうなるか。
どう考えるか
まず、最初に使える集合はxs = [a,b,c,d]である。仮に最初にbを使うなら、次に使えるのはxsからbを除いた集合delete b xsになる。よく考えてみると、bの後ろにつながるのはこの集合delete b xsつまり[a,c,d]の順列であることに気がつくから
map (b:) (permutate (delete b xs))
でbから始まる順列の全体が得られることがわかる。この操作をbだけでなく[a,b,c,d]つまりxsの全体に対して行ってやればいいからbの所を仮引数xに置き換えてラムダ式を作ってそれをxsにmapすればいい。つまり
map (\x -> map (x:) (permutate (delete x xs))) xs
で、これは[[aから始まる順列のリスト],[bから始まる順列のリスト],[cから始まる順列のリスト],[dから始まる順列のリスト]]と、順列のリストのリストになっているから、concatで潰してやれば型が合う（mapと併せてconcatMapにすればいい）。その結果が冒頭のコードである
permutate [] = [[]]
permutate xs = concatMap (\x -> map (x:) (permutate (delete x xs))) xs
実はconcatMap f xsはリストモナドのxs >>= fに対応するので
permutate [] = return []
permutate xs = xs >>= (\x -> map (x:) (permutate (delete x xs)))
つまり
permutate [] = return []
permutate xs = do
x <- xs
map (x:) $ permutate $ delete x xs
と書くこともできる。
攪乱順列を構成する（ほんのすこし発展）
攪乱順列 (derangement)は、元のリストと同じ位置には同じ要素が決して来ないような、順列のことである（つまり椅子に座っている全員が席替えをする場合のような順列）。たとえば[1,2,3]の攪乱順列は[2,3,1]と[3,1,2]の2つだけである。この攪乱順列も普通の順列の場合と似た方法で一工夫すれば、構成することができる。
import Data.List (delete)
derange :: [a] -> [[a]]
derange xs = derange' xs xs
derange' [] _ = [[]]
derange' xs (y:ys) = concatMap (\x -> map (x:) (derange' (delete x xs) ys)) (delete y xs)
どう考えるか
先ほどと同じようにやるのだが、今度は順列を構成している時に、いま自分が元々のリストのどの位置にあたる要素を操作しているかを覚えておかなくてはならない（攪乱順列なので元々のリストのその要素はその位置には入れられない）。覚えて置かなければならない情報は引数に突っ込むのが関数型の基本戦略なのでそうする。構成中にその場面で選んではいけない要素を引数で管理するのである。
derange xs = derange' xs xs
derange' xs (y:ys) = ?
攪乱順列を構成する関数は基本的にこんな感じになるはずだ。derange' xs (y:ys)の(y:ys)は自分が元々のリストのどの位置に相当する場面まで来ているかを表している（yが選ばれないようにしつつ要素をひとつ配置し終わったらtailして現在位置を進めていく）。
ここでもまずはxsが[a,b,c,d]の場合を考えよう。まず最初の要素はa以外でなくてはならないからdelete a [a,b,c,d]から選ぶことになる。delete a [a,b,c,d]の中から仮にdを選んだとすると、残りの要素はdelete d xsつまり[a,b,c]になる。次の要素を選ぶ手順に入るが、ここで元々のリストのaにあたる位置の処理が終わったので、現在の位置を示す(y:ys)をひとつ先に進める必要がある(つまりysだ)。xsから選んではいけない要素をysを参照して脇にどけつつ順列を作る関数がderange'なのだから、dの後ろは再帰で作れる
map (d:) (derange' (delete d xs) ys)
この操作と同じことをラムダ式で書いて、それをdelete a [a,b,c,d]つまりdelete y xsのそれぞれについて適用してやればいいから、mapを使って
map (\x -> map (x:) (derange' (delete x xs) ys)) (delete y xs)
で、これをconcatして潰してやれば型が合うことになる
derange xs = derange' xs xs
derange' [] _ = [[]]
derange' xs (y:ys) = concatMap (\x -> map (x:) (derange' (delete x xs) ys)) (delete y xs)
ここでも敢えてモナド表記をすれば
derange :: Eq a => [a] -> [[a]]
derange = join derange'
derange' _ [] = return []
derange' (y:ys) xs = do
x <- delete y xs
map (x:) $ derange' ys $ delete x xs
こんな感じになる。
与えられたリストからn個のものを選びだす（これは簡単）
choose :: [a] -> Int -> [[a]]
choose [] _ = []
choose xs 1 = map (:[]) xs
choose (x:xs) n = map (x:) (choose xs (n-1)) ++ choose xs n
どう考えるか
見たまんま。