[Haskell-cafe] permutations and performance

[John D. Ramsdell]

I tried to replace a permutation generator with one that generates
each permutation from the previous one, in a stream-like fashion.  I
had hoped the stream-based algorithm would be more efficient because I
use only one permutation at a time, so only the permutation and the
previous one need be in memory at one time.  I thought I'd share the
results of testing the two algorithms.

I first forced the algorithms to produce answers by printing the
length of their results.  Bad idea.  The stream-based algorithm
produces a stack overflow on an input that it can handle when the
contents of every permutation is forced.  In this run, touch = length.

$ ghc -O perms.lhs
$ echo '(True, 9)' | ./a.out
Stack space overflow: current size 8388608 bytes.
Use `+RTS -Ksize' to increase it.
$ echo '(False, 9)' | ./a.out
362880
$

I forced all parts of the computation by summing all of the numbers in
the output.  The result show the more obvious algorithm is faster.

$ ghc -O perms.lhs
$ echo '(True, 12)' | time ./a.out
31614105600
299.56user 0.97system 5:00.75elapsed 99%CPU (0avgtext+0avgdata 0maxresident)k
0inputs+0outputs (0major+479minor)pagefaults 0swaps
$ echo '(False, 12)' | time ./a.out
31614105600
213.86user 0.55system 3:34.90elapsed 99%CPU (0avgtext+0avgdata 0maxresident)k
0inputs+0outputs (0major+841minor)pagefaults 0swaps
$

> module Main(main) where

> main =
>     do (new, n) <- readLn :: IO (Bool, Int)
>        case new of
>          True -> print $ touch $ npermutations n
>          False -> print $ touch $ permutations n

Touch all the numbers in the output.  Originally, touch = length.

> touch :: [[Int]] -> Int
> touch xs =
>     sum (map sum xs)

The permutation algorithm used by Serge Mechveliani in The Algebraic
Domain Constructor DoCon.  The idea of the algorithm was suggested to
him by S.M.Abramov.

> npermutations :: Int -> [[Int]]
> npermutations n =
>     first : next (spanMonotoneous first)
>     where
>       first = take n [0..]
>       next (_ , []) = []
>       next (decr, j:js) =
>           p : next (spanMonotoneous p)
>           where
>             p = concat [reverse smallers, [j], reverse greaters, [i], js]
>             (greaters, i:smallers) = span (> j) decr
>       spanMonotoneous (x:y:xs)
>           | x <= y = ([x], y:xs)
>           | otherwise = (x:ys, zs)
>               where
>                 (ys,zs) = spanMonotoneous (y:xs)
>       spanMonotoneous xs = (xs, [])
>           p : next (spanMonotoneous p)
>           where
>             p = concat [reverse smallers, [j], reverse greaters, [i], js]
>             (greaters, i:smallers) = span (> j) decr
>       spanMonotoneous (x:y:xs)
>           | x <= y = ([x], y:xs)
>           | otherwise = (x:ys, zs)
>               where
>                 (ys,zs) = spanMonotoneous (y:xs)
>       spanMonotoneous xs = (xs, [])

Straight forward permation algorithm.

> permutations :: Int -> [[Int]]
> permutations n
>     | n <=  0 = []
>     | n == 1 = [[0]]
>     | otherwise =
>         concatMap (insertAtAllPos (n - 1)) (permutations (n - 1))
>     where
>       insertAtAllPos x [] = [[x]]
>       insertAtAllPos x (y : l) =
>           (x : y : l) : map (y :) (insertAtAllPos x l)