Permutation implementation in Haskell

Question

I was trying to implement permutation of a list in Haskell. The idea for permutations is this:

The base cases are when list length is 0 and 1 which is the list itself, and when size is 2, the permutation gives the list itself along with swapped elements.

Now, given a list [a,b,c,d] we permute [b,c,d] and append with a. and we change our list to have b in the first like [b,a,c,d] and permute [a,c,d] and so on, recursively.

So far, I have done the following code in Haskell. Which perfectly works. But I am not satisfied with the level of 'haskell-ness' that this contains. I would like to have some hints on how to make this more readable and efficient in haskell. Thanks in advance. The code is below:

-- swap the first element of a list with the element at the index
swapFirstWith index l | index == 0 = l
                      | otherwise =  [l!!index]
                        ++ (take (index-1) (tail l))
                        ++ [head l]
                        ++ (drop (index+1) l)


permutations :: [a] -> [[a]]
permutations [] = [[]]
permutations [a] = [[a]]
permutations [a,b] = [[a,b], [b,a]]
permutations lst = foldl (++) [] (map (\x-> miniperms x) swappedList)
    where miniperms l = map (\x-> (head l): x) $ permutations (tail l)
          swappedList = map (\(i, x) -> swapFirstWith i lst) (zip [0..] lst)


main = do
    putStrLn $ show $ perms
    putStrLn $ show $ length perms
    where lst = [1,2,3,4,5,6,7,8,9]
          perms =  permutations lst

Answer 1

Avoid !!,head,tail in favor of pattern matching. Such functions are partial, and can crash your program when the list is too short. Pattern matching (when exhaustive) has no such issues.

length, take, drop are often better left unused.

Instead, let us consider the simple recursion:

perms :: [a] -> [[a]]
perms []     = [[]]
perms (x:xs) = doSomething x (perms xs)

How to turn perms xs into perms (x:xs)? In each permutation p of xs, we need to insert x at any possible point of p. We get

perms :: [a] -> [[a]]
perms []     = [[]]
perms (x:xs) = [ p' | p <- perms xs, (use insert here) ]

where inserting at all points is done as follows

insert :: a -> [a] -> [[a]]
insert x [] = [[x]]
insert x (y:ys) = ... -- todo

I'll leave to you to complete the code.

Answer 2

With

picks :: [t] -> [([t], t)]
picks [] = []
-- picks [x] = [([],x)]
picks (x:xs) = [(xs,x)] ++ [(x:ys,y) | (ys,y) <- picks xs]

it is, straightforwardly,

perms :: [t] -> [[t]]
perms [] = [[]]
perms xs =         -- [(x:zs) | (ys,x) <- picks xs, zs <- perms ys]  
  do                     
    (ys,x) <- picks xs        -- pick an element, any element
    zs     <- perms ys        -- permute what's left
    return (x:zs)             -- and put them together     

---

edit: The repetitive pattern of creating and passing around the updated domain suggests that we can do better, i.e. make it so that the correct domains are passed around automatically behind the scenes for us, as a part of this specific computational model's "pipeline", as it were.

Right now we have to worry about making a mistake, to name the interim domains explicitly, and to be extra careful to pass the correct variable around as the domain to be used. It's good to have these worries taken care of automatically for us.

Specific notions of computation are captured with a specific instance of a Monad type class.

With the help of "unique selection" monad from an answer by Louis Wasserman,

newtype UniqueSel t a = UniqueSel {runUS :: [t]  ->  [ ([t],  a) ] }
--                                       domain   updated_dom, result
instance Functor (UniqueSel t) where
    fmap = liftM
instance Applicative (UniqueSel t) where
    pure a = UniqueSel (\ choices -> [(choices, a)])    -- unchanged domain
    (<*>)  = ap 
instance Monad (UniqueSel t) where
    return  = pure
    m >>= k = UniqueSel (\ choices -> [ r | (cs, a) <- runUS m choices,
                                            r       <- runUS (k a) cs ])

we could re-write the above list-based do code as UniqueSel-based do code,

perm = do { x <- UniqueSel picks ; xs <- perm ; return (x:xs) }

where all the interim domain tracking variables have just disappeared! The nature of what we're doing here has become much clearer and more apparent. There's no distractions anymore.

This last code snippet won't work though, as we don't guard against making a selection from an empty domain, which will happen and will effectively abort all computations, producing just [] in the end. We need to return an [] as the result for the empty domains, ourselves.

We could introduce new "primitive" action in our little uniquely-selecting computations language, to bring the hidden choices into our universe, with choices = UniqueSel (\cs -> [(cs, cs)]); and branch on the empty domain, like

perm = do { cs <- choices ; if (null cs) then return [] else
            do {  x <- UniqueSel picks ; xs <- perm ; return (x:xs) } }

and run this computation description that we've built, by using perms = map snd . runUS perm; but this pattern is already captured for us in the standard library, in the module Control.Monad, as the function sequence; so we can just define

perms :: [t] -> [[t]]
perms = map snd . (runUS =<< sequence . (UniqueSel picks <$))

-- perms xs = map snd $ runUs (sequence [UniqueSel picks | _ <- xs]) xs
--          = .....           (replicateM (length xs) (UniqueSel picks)) xs

This runs the input through the sequence of picks of the same length as the input.

Indeed, to permute an n-long list is to make n arbitrary selections from the ever shrinking pool of possible choices.

Answer 3

Recursion version, having the implementation of permutations for N - 1, in order to get the implementation for N you need just to take N-th element and insert it into every possible position of permutations for N - 1

permutations :: [a] -> [[a]]
permutations [] = [[]]
permutations [a] = [[a]]
permutations (x:xs) =  (>>=) (permutations xs)  (merge x)
    where
        insertAt :: Int -> a-> [a] -> [a] 
        insertAt z y xs = as ++ (y:bs)
                  where (as,bs) = splitAt z xs
        merge :: a -> [a] -> [[a]]
        merge x p = map (\i -> insertAt i x p) [0..length p]