Combinations and Permutations in F#

Question

I've recently written the following combinations and permutations functions for an F# project, but I'm quite aware they're far from optimised.

/// Rotates a list by one place forward.
let rotate lst =
    List.tail lst @ [List.head lst]

/// Gets all rotations of a list.
let getRotations lst =
    let rec getAll lst i = if i = 0 then [] else lst :: (getAll (rotate lst) (i - 1))
    getAll lst (List.length lst)

/// Gets all permutations (without repetition) of specified length from a list.
let rec getPerms n lst = 
    match n, lst with
    | 0, _ -> seq [[]]
    | _, [] -> seq []
    | k, _ -> lst |> getRotations |> Seq.collect (fun r -> Seq.map ((@) [List.head r]) (getPerms (k - 1) (List.tail r)))

/// Gets all permutations (with repetition) of specified length from a list.
let rec getPermsWithRep n lst = 
    match n, lst with
    | 0, _ -> seq [[]]
    | _, [] -> seq []
    | k, _ -> lst |> Seq.collect (fun x -> Seq.map ((@) [x]) (getPermsWithRep (k - 1) lst))
    // equivalent: | k, _ -> lst |> getRotations |> Seq.collect (fun r -> List.map ((@) [List.head r]) (getPermsWithRep (k - 1) r))

/// Gets all combinations (without repetition) of specified length from a list.
let rec getCombs n lst = 
    match n, lst with
    | 0, _ -> seq [[]]
    | _, [] -> seq []
    | k, (x :: xs) -> Seq.append (Seq.map ((@) [x]) (getCombs (k - 1) xs)) (getCombs k xs)

/// Gets all combinations (with repetition) of specified length from a list.
let rec getCombsWithRep n lst = 
    match n, lst with
    | 0, _ -> seq [[]]
    | _, [] -> seq []
    | k, (x :: xs) -> Seq.append (Seq.map ((@) [x]) (getCombsWithRep (k - 1) lst)) (getCombsWithRep k xs)

Does anyone have any suggestions for how these functions (algorithms) can be sped up? I'm particularly interested in how the permutation (with and without repetition) ones can be improved. The business involving rotations of lists doesn't look too efficient to me in retrospect.

Update

Here's my new implementation for the getPerms function, inspired by Tomas's answer.

Unfortunately, it's not really any fast than the existing one. Suggestions?

let getPerms n lst =
    let rec getPermsImpl acc n lst = seq {
        match n, lst with
        | k, x :: xs ->
            if k > 0 then
                for r in getRotations lst do
                    yield! getPermsImpl (List.head r :: acc) (k - 1) (List.tail r)
            if k >= 0 then yield! getPermsImpl acc k []
        | 0, [] -> yield acc
        | _, [] -> ()
        }
    getPermsImpl List.empty n lst

Answer 1

If you have a real need for speed, I encourage you to first find the fastest algorithm for your problem and if the algorithm turns out to be inherently imperative (e.g. bubble sort or the Sieve of Eratosthenes), by all means, use F#'s imperative features for your implementation internally while keeping your API pure for library consumers (more work and risk for you, but excellent results for library consumers).

Specific to your question, I've adapted my fast implementation for generating all permutations of a set lexicographically (originally presented here) to generate r-length permutations:

open System
open System.Collections.Generic

let flip f x y = f y x

///Convert the given function to an IComparer<'a>
let comparer f = { new IComparer<_> with member self.Compare(x,y) = f x y }

///generate r-length lexicographical permutations of e using the comparison function f.
///permutations start with e and continue until the last lexicographical permutation of e:
///if you want all permuations for a given set, make sure to order e before callings this function.
let lexPerms f r e =
    if r < 0 || r > (Seq.length e) then
        invalidArg "e" "out of bounds" |> raise

    //only need to compute IComparers used for Array.Sort in-place sub-range overload once
    let fComparer = f |> comparer
    let revfComparer = f |> flip |> comparer

    ///Advances (mutating) perm to the next lexical permutation.
    let lexPermute perm =
        //sort last perm.Length - r elements in decreasing order,
        //thereby avoiding duplicate permutations of the first r elements
        //todo: experiment with eliminate this trick and instead concat all
        //lex perms generated from ordered combinations of length r of e (like cfern)
        Array.Sort(perm, r, Array.length perm - r, revfComparer)

        //Find the index, call it s, just before the longest "tail" that is
        //ordered  in decreasing order ((s+1)..perm.Length-1).
        let rec tryFind i =
            if i = 0 then
                None
            elif (f perm.[i] perm.[i-1]) >= 0 then
                Some(i-1)
            else
                tryFind (i-1)

        match tryFind (perm.Length-1) with
        | Some s ->
            let sValue = perm.[s]

            //Change the value just before the tail (sValue) to the
            //smallest number bigger than it in the tail (perm.[t]).
            let rec find i imin =
                if i = perm.Length then
                    imin
                elif (f perm.[i] sValue) > 0 && (f perm.[i] perm.[imin]) < 0 then
                    find (i+1) i
                else
                    find (i+1) imin

            let t = find (s+1) (s+1)

            perm.[s] <- perm.[t]
            perm.[t] <- sValue

            //Sort the tail in increasing order.
            Array.Sort(perm, s+1, perm.Length - s - 1, fComparer)
            true
        | None ->
            false

    //yield copies of each perm
    seq {
        let e' = Seq.toArray e
        yield e'.[..r-1]
        while lexPermute e' do
            yield e'.[..r-1]
    }

let lexPermsAsc r e = lexPerms compare r e
let lexPermsDesc r e = lexPerms (flip compare) r e

I am not sure if adapting this algorithm to r-length permutations is terribly inappropriate (i.e. whether there are better imperative or functional algorithms specifically for this problem), but it does, on average, perform almost twice as fast as your latest getPerms implementation for the set [1;2;3;4;5;6;7;8;9], and has the additional feature of yielding the r-length permutations lexicographically (notice also with interest how lexPermsAsc is not monotonic as a function of r):

r       lexPermsAsc(s)  getPerms(s)
1       0.002           0.002
2       0.004           0.002
3       0.019           0.007
4       0.064           0.014
5       0.264           0.05
6       0.595           0.307
7       1.276           0.8
8       1.116           2.247
9       1.107           4.235
avg.:   0.494           0.852

Answer 2

I noticed that your updated getPerms function contains duplicates. Here's my crack at a dupe-free version. Hopefully the comments speak for themselves. The hardest part was writing an efficient distrib function, because the concatenation operator has to be used somewhere. Luckily it's only used on small sublists, so the performance remains reasonable. My getAllPerms code below generates all permutations of [1..9] in around a quarter of a second, all 10-element permutations in around 2.5 seconds.

Edit: funny, I didn't look at Tomas' code, but his combinations function and my picks function are nearly identical.

// All ordered picks {x_i1, x_i2, .. , x_ik} of k out of n elements {x_1,..,x_n}
// where i1 < i2 < .. < ik
let picks n L = 
    let rec aux nleft acc L = seq {
        match nleft,L with
        | 0,_ -> yield acc
        | _,[] -> ()
        | nleft,h::t -> yield! aux (nleft-1) (h::acc) t
                        yield! aux nleft acc t }
    aux n [] L

// Distribute an element y over a list:
// {x1,..,xn} --> {y,x1,..,xn}, {x1,y,x2,..,xn}, .. , {x1,..,xn,y}
let distrib y L =
    let rec aux pre post = seq {
        match post with
        | [] -> yield (L @ [y])
        | h::t -> yield (pre @ y::post)
                  yield! aux (pre @ [h]) t }
    aux [] L

// All permutations of a single list = the head of a list distributed
// over all permutations of its tail
let rec getAllPerms = function
    | [] -> Seq.singleton []
    | h::t -> getAllPerms t |> Seq.collect (distrib h)

// All k-element permutations out of n elements = 
// all permutations of all ordered picks of length k combined
let getPerms2 n lst = picks n lst |> Seq.collect getAllPerms

Edit: more code in response to comments

// Generates the cartesian outer product of a list of sequences LL
let rec outerProduct = function
    | [] -> Seq.singleton []
    | L::Ls -> L |> Seq.collect (fun x -> 
                outerProduct Ls |> Seq.map (fun L -> x::L))

// Generates all n-element combination from a list L
let getPermsWithRep2 n L = 
    List.replicate n L |> outerProduct  

Answer 3

If you want to write efficient functional code, then it is a good idea to avoid using the @ operator, because concatentation of lists is very inefficient.

Here is an example of how you can write a function to generate all combinations:

let rec combinations acc size set = seq {
  match size, set with 
  | n, x::xs -> 
      if n > 0 then yield! combinations (x::acc) (n - 1) xs
      if n >= 0 then yield! combinations acc n xs 
  | 0, [] -> yield acc 
  | _, [] -> () }

combinations [] 3 [1 .. 4]

The parameters of the function are:

• acc is used to remember elements that are already selected to be included in the combination (initially this is an empty list)
• size is the remaining number of elements that we need to add to acc (initially this is the required size of the combinations)
• set is the set elements to choose from

The function is implemented using a simple recursion. If we need to generate combinations of size n then we can either add or don't add the current element, so we try to generate combinations using both options (first case) and add all of them to the generated sequence using yield!. If we need 0 more elements, then we successfuly generated a combination (second case) and if we end with some other number but don't have any remaining elements to use then we cannot return anything (last case).

Combinations with repetition would be similar - the difference is that you don't need to remove the elements from the list (by using just xs in the recursive calls) so there are more options of what to do.