I am trying to get a function (given as a parameter a set) to return a set whose elements are all the subset formed from the main set.
Ex: {1;2;3} -> { {1}, {2}, {3}, {1,2}, {1,3}, {2,3}, {1,2,3} }
But I don't exactly know how to make a module that lets me work with a set of sets. What type should I define it as?
A set of all subsets is called a power set. To implement an algorithm you don't really need a special data structure, as you can represent a set with a list. Correspondingly a set of sets would be a list of lists. E.g.,
let rec superset = function
| [] -> [[]]
| x :: xs ->
let ps = superset xs in
ps # List.map (fun ss -> x :: ss) ps
And here is an example of usage:
superset [1;2;3];;
- : int list list = [[]; [1]; [2]; [2; 1]; [3]; [3; 1]; [3; 2]; [3; 2; 1]
If you want to use real sets, like Jeffrey suggested. Then we will need to adapt the algorithm a little bit, since Set module provides a little bit different interface.
module S = Set.Make(String)
module SS = Set.Make(S)
let superset xs =
S.fold (fun x ps ->
SS.fold (fun ss -> SS.add (S.add x ss)) ps ps) xs
(SS.singleton S.empty)
To run the algorithm and to print the result we need to transform it back to a list, since OCaml toplevel doesn't know how to print sets:
# superset (S.of_list ["1"; "2"; "3"]) |> SS.elements |> List.map S.elements;;
- : S.elt list list =
[[]; ["1"]; ["1"; "2"]; ["1"; "2"; "3"]; ["1"; "3"]; ["2"]; ["2"; "3"];
["3"]]
Now, we can generalize algorithm, so that it will work on any ordered type.
module Superset(T : Set.OrderedType) = struct
module S = Set.Make(T)
module SS = Set.Make(S)
let of_set xs =
S.fold (fun x ps ->
SS.fold (fun ss -> SS.add (S.add x ss)) ps ps) xs
(SS.singleton S.empty)
end
Now we can run it:
# module Superset_of_strings = Superset(String);;
# open Superset_of_string;;
# of_set (S.of_list ["1"; "2"; "3"]) |> SS.elements |> List.map S.elements;;
- : S.elt list list =
[[]; ["1"]; ["1"; "2"]; ["1"; "2"; "3"]; ["1"; "3"]; ["2"]; ["2"; "3"];
["3"]]
If you want to use the standard Set module, you can work with sets of strings (say) and sets of sets of strings like this:
# module S = Set.Make(String);;
. . .
# module SS = Set.Make(S);;
. . .
# let s1 = S.singleton "abc";;
val s1 : S.t = <abstr>
# let ss1 = SS.singleton s1;;
val ss1 : SS.t = <abstr>
# List.map S.elements (SS.elements ss1);;
- : S.elt list list = [["abc"]]
Related
I have a list of pairs of views which represents list of content labels and their widths which I want to group in lines (if the next content label doesn't fit in line then put it into another line). So we have: viewList = [(View1, 45), (View2, 223.5), (View3, 14) (View4, 42)].
I want to write a function groupViews :: [a] -> [[a]] to group this list into a list of sublists where each sublist will contain only views with sum of widths less than the maximum specified width (let's say 250).
So for a sorted viewList this function will return : [[(View3, 14), (View4, 42), (View1, 45)],[(View2, 223.5)]]
It looks similar to groupBy. However, groupBy doesn't maintain an accumulator. I tried to use scanl + takeWhile(<250) combination but in this case I was able to receive only first valid sublist. Maybe use iterate + scanl + takeWhile somehow? But this looks very cumbersome and not functional at all. Any help will be much appreciated.
I would start with a recursive definition like this:
groupViews :: Double -> (a -> Double) -> [a] -> [[a]]
groupViews maxWidth width = go (0, [[]])
where
go (current, acc : accs) (view : views)
| current + width view <= maxWidth
= go (current + width view, (view : acc) : accs) views
| otherwise = go (width view, [view] : acc : accs) views
go (_, accs) []
= reverse $ map reverse accs
Invoked like groupViews 250 snd (sortOn snd viewList). The first thing I notice is that it can be represented as a left fold:
groupViews' maxWidth width
= reverse . map reverse . snd . foldl' go (0, [[]])
where
go (current, acc : accs) view
| current + width view <= maxWidth
= (current + width view, (view : acc) : accs)
| otherwise
= (width view, [view] : acc : accs)
I think this is fine, though you could factor it further if you like, into one scan to accumulate the widths modulo the max width, and another pass to group the elements into ascending runs. For example, here’s a version that works on integer widths:
groupViews'' maxWidth width views
= map fst
$ groupBy ((<) `on` snd)
$ zip views
$ drop 1
$ scanl (\ current view -> (current + width view) `mod` maxWidth) 0 views
And of course you can include the sort in these definitions instead of passing the sorted list from outside.
I don't know a clever way to do this just by combining functions from the standard library, but I do think you can do better than just implementing it from scratch.
This problem fits into a class of problems that I've seen before: "batch up items from this list somehow, and combine its items into batches according to some combination rule and some rule for deciding when a batch is too big". Years ago, when I was writing Clojure, I built a function that abstracted out this idea of batched combinations, just asking you to specify the rules for batching, and was able to use it in a surprising number of places.
Here's how I think it might be reimagined in Haskell:
glue :: Monoid a => (a -> Bool) -> [a] -> [a]
glue tooBig = go mempty
where go current [] = [current]
go current (x:xs) | tooBig x' = current : go x xs
| otherwise = go x' xs
where x' = current `mappend` x
If you had such a glue function already, you could build a simple data type with the appropriate Monoid instance (a list of objects and their cumulative sum), and then let glue do the heavy lifting:
import Data.Monoid (Sum(..))
data ViewGroup contents size = ViewGroup {totalSize :: size,
elements :: [(contents, size)]}
instance Monoid b => Monoid (ViewGroup a b) where
mempty = ViewGroup mempty []
mappend (ViewGroup lSize lElts) (ViewGroup rSize rElts) =
ViewGroup (lSize `mappend` rSize)
(lElts ++ rElts)
viewGroups = let views = [("a", 14), ("b", 42), ("c", 45), ("d", 223.5)]
in glue ((> 250) . totalSize) [ViewGroup (Sum width) [(x, Sum width)]
| (x, width) <- views]
main = print (viewGroups :: [ViewGroup String (Sum Double)])
[ViewGroup {totalSize = Sum {getSum = 101.0},
elements = [("a",Sum {getSum = 14.0}),
("b",Sum {getSum = 42.0}),
("c",Sum {getSum = 45.0})]},
ViewGroup {totalSize = Sum {getSum = 223.5},
elements = [("d",Sum {getSum = 223.5})]}]
On the one hand this looks like quite a bit of work for a simple function, but on the other it's rather nice to have a type that describes the cumulative summing you're doing, and Monoid instances are nice to have anyway...and after defining the type and the Monoid instance there's almost no work left to do in the calling of glue itself.
Well, I don't know, maybe it's still too much work, especially if you don't believe you can reuse that type. But I do think it's useful to recognize that this is a specific case of a more general problem, and try to solve the more general problem as well.
Given that groupBy and span themselves are defined by manual recursive functions, our modified functions will use the same mechanism.
Let us first define a general function groupAcc which takes an initial value for the accumulator, and then a function which takes an element in the list, the current accumulator state and potentially produces a new accumulated value (Nothing means the element is not accepted):
{-# LANGUAGE LambdaCase #-}
import Data.List (sortOn)
import Control.Arrow (first, second)
spanAcc :: z -> (a -> z -> Maybe z) -> [a] -> ((z, [a]), [a])
spanAcc z0 p = \case
xs#[] -> ((z0, xs), xs)
xs#(x:xs') -> case p x z0 of
Nothing -> ((z0, []), xs)
Just z1 -> first (\(z2, xt) -> (if null xt then z1 else z2, x : xt)) $
spanAcc z1 p xs'
groupAcc :: z -> (a -> z -> Maybe z) -> [a] -> [(z, [a])]
groupAcc z p = \case
[] -> [] ;
xs -> uncurry (:) $ second (groupAcc z p) $ spanAcc z p xs
For our specific problem, we define:
threshold :: (Num a, Ord a) => a -> a -> a -> Maybe a
threshold max a z0 = let z1 = a + z0 in if z1 < max then Just z1 else Nothing
groupViews :: (Ord z, Num z) => [(lab, z)] -> [[(lab, z)]]
groupViews = fmap snd . groupAcc 0 (threshold 250 . snd)
Which finally gives us:
groupFinal :: (Num a, Ord a) => [(lab, a)] -> [[(lab, a)]]
groupFinal = groupViews . sortOn snd
And ghci gives us:
> groupFinal [("a", 45), ("b", 223.5), ("c", 14), ("d", 42)]
[[("c",14.0),("d",42.0),("a",45.0)],[("b",223.5)]]
If we want to, we can simplify groupAcc by assuming that z is a Monoid wherefore mempty may be used, such that:
groupAcc2 :: Monoid z => (a -> z -> Maybe z) -> [a] -> [(z, [a])]
groupAcc2 p = \case
[] -> [] ;
xs -> let z = mempty in
uncurry (:) $ second (groupAcc z p) $ spanAcc z p xs
In Matlab we can write the following code to shuffle a matrix:
data = data(:, randperm(size(data,2)));
there is what I write with Math.NET:
let csvfile = #"../UFLDL-tutorial-F#/housing.csv"
let housingAsLines =
File.ReadAllLines(csvfile)
|> Array.map (fun t -> t.Split(',')
|> Array.map (fun t -> float t))
let housingAsMatrix= DenseMatrix.OfRowArrays housingAsLines
let housingAsMatrixT = housingAsMatrix.Transpose()
let v1 = DenseVector.Create(housingAsMatrixT.ColumnCount,1.0)
housingAsMatrixT.InsertRow(0,v1)
// How to shuffle a "DenseMatrix" in F#
To simulate matrix operation in Matlab, using the F# slice syntax and zero-based indexing. However, it doesn't work.
housingAsMatrixT.[*,0]
And I got the error message in vscode.
The field, constructor or member 'GetSlice' is not defined
You actually have two questions, 1) how to slice Matrices ala matlab and 2) how to shuffle the columns of a matrix.
For 1) actually Issue 277 you linked in the comment does indeed provide the solution. However you might be using an old version or you might not be referencing the F# extensions correctly:
#r #"..\packages\MathNet.Numerics.3.13.1\lib\net40\MathNet.Numerics.dll"
#r #"..\packages\MathNet.Numerics.FSharp.3.13.1\lib\net40\MathNet.Numerics.FSharp.dll"
open MathNet.Numerics
open MathNet.Numerics.LinearAlgebra
open MathNet.Numerics.Distributions
open System
//let m = DenseMatrix.randomStandard<float> 5 5
let m = DenseMatrix.random<float> 5 5 (ContinuousUniform(0., 1.))
let m' = m.[*,0]
m'
//val it : Vector<float> =
//seq [0.4710989485; 0.2220238937; 0.566367266; 0.2356496324; ...]
This extracts the first column of the matrix.
Now for 2), assuming you need to shuffle the matrix or the arrays containing a matrix you can use some of the approaches below. There might be a more elegant method within mathnet.numerics.
To permute the vector above: m'.SelectPermutation() or SelectPermutationInplace for arrays. There are other convenience function like .Column(idx),.EnumerateColumnsIndexed() or EnumerateColumns(), etc.
So m'.SelectPermutation() will shuffle the elements of m'. Or to shuffle the columns (which your matlab function does):
let idx = Combinatorics.GeneratePermutation 5
idx
//val it : int [] = [|2; 0; 1; 4; 3|]
let m2 = idx |> Seq.map (fun i -> m.Column(i)) |> DenseMatrix.ofColumnSeq
m2.Column(1) = m.Column(0)
//val it : bool = true
Since the first column of the original matrix moved to the second column of the new matrix, the two should be equal.
With Neural Networks I had to shuffle an array of Matrices and used the following code. Note the base data structure is an array ([]) and each item in the array is a Matrix. This is not shuffling a matrix, but an array. It should give you some idea of how to proceed for your problem.
type Random() =
static member Shuffle (a : 'a[]) =
let rand = new System.Random()
let swap (a: _[]) x y =
let tmp = a.[x]
a.[x] <- a.[y]
a.[y] <- tmp
Array.iteri (fun i _ -> swap a i (rand.Next(i, Array.length a))) a
and called it like
Random.Shuffle trainingData
Addendum
Here is the code to convert a byte[] to a DenseMatrix of double
let byteArrayToMatrix (bytes : byte[]) : Matrix<double> =
let (x : Vector<byte>) = Vector<byte>.Build.DenseOfArray bytes
let (y : Vector<double>) = x.Map(fun x -> double x)
let (z : Matrix<double>) = Matrix<double>.Build.DenseOfRowVectors y
z
#GuyCoder and #s952163, thanks for your help. I implemented a quick-and-dirty version. It is not good enough but it works.
Please feel free to comment. Thank you.
#load "../packages/FsLab.1.0.2/FsLab.fsx"
open System
open System.IO
open MathNet.Numerics.LinearAlgebra.Double
open MathNet.Numerics
open MathNet.Numerics.LinearAlgebra
open MathNet.Numerics.Distributions
// implementation of the Fisher-Yates shuffle by Mathias
// http://www.clear-lines.com/blog/post/Optimizing-some-old-F-code.aspx
let swap fst snd i =
if i = fst then snd else
if i = snd then fst else
i
let shuffle items (rng: Random) =
let rec shuffleTo items upTo =
match upTo with
| 0 -> items
| _ ->
let fst = rng.Next(upTo)
let shuffled = List.permute (swap fst (upTo - 1)) items
shuffleTo shuffled (upTo - 1)
let length = List.length items
shuffleTo items length
let csvfile = #"/eUSB/sync/fsharp/UFLDL-tutorial-F#/housing.csv"
let housingAsLines =
File.ReadAllLines(csvfile)
|> Array.map (fun t -> t.Split(',')
|> Array.map (fun t -> float t))
let housingAsMatrix= DenseMatrix.OfRowArrays housingAsLines
let housingAsMatrixTmp = housingAsMatrix.Transpose()
let v1 = DenseVector.Create(housingAsMatrixTmp.ColumnCount,1.0)
let housingAsMatrixT = housingAsMatrixTmp.InsertRow(0,v1)
let m = housingAsMatrixT.RowCount - 1
let listOfArray = [0..m]
let random = new Random()
let shuffled = shuffle listOfArray random
let z = [for i in shuffled -> (housingAsMatrixT.[i, *])]
let final = DenseMatrix.OfRowVectors z
So this is a merge sort function I'm playing with in OCaml. The funny thing is the code delivers what I expect, which means, it sorts the list. But then raises some errors. So can someone please check my code and tell me what's going on and why these errors? And how do I eliminate them? I'm a OCaml newbie but I really want to get what's going on:
(* Merge Sort *)
(* This works but produces some extra error. Consult someone!! *)
let rec length_inner l n =
match l with
[] -> n
| h::t -> length_inner t (n + 1)
;;
let length l = length_inner l 0;;
let rec take n l =
if n = 0 then [] else
match l with
h::t -> h :: take (n - 1) t
;;
let rec drop n l =
if n = 0 then l else
match l with
h::t -> drop (n - 1) t
;;
let rec merge x y =
match x, y with
[], l -> l
| l, [] -> l
| hx::tx, hy::ty ->
if hx < hy
then hx :: merge tx (hy :: ty)
else hy :: merge (hx :: tx) ty
;;
let rec msort l =
match l with
[] -> []
| [x] -> [x]
| _ ->
let left = take (length l/2) l in
let right = drop (length l/2) l in
merge (msort left) (msort right)
;;
msort [53; 9; 2; 6; 19];;
In the terminal, I get:
OCaml version 4.00.1
# #use "prac.ml";;
val length_inner : 'a list -> int -> int = <fun>
val length : 'a list -> int = <fun>
File "prac.ml", line 13, characters 2-44:
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a value that is not matched:
[]
val take : int -> 'a list -> 'a list = <fun>
File "prac.ml", line 19, characters 2-39:
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a value that is not matched:
[]
val drop : int -> 'a list -> 'a list = <fun>
val merge : 'a list -> 'a list -> 'a list = <fun>
val msort : 'a list -> 'a list = <fun>
- : int list = [2; 6; 9; 19; 53]
#
The compiler is telling you that your pattern matches aren't exhaustive. In fact it's telling exactly what to try to see the problem. For example, you might try:
drop 2 []
To fix the problem you need to decide what to do with empty lists in your functions. Here's a definition of drop with exhaustive matches:
let rec drop n l =
if n = 0 then l
else
match l with
| [] -> []
| h::t -> drop (n - 1) t
If this isn't clear: your code doesn't say what to do with an empty list. Your matches only say what to do if the list has the form h :: t. But an empty list doesn't have this form. You need to add a case for [] to your matches.
Given a sequence of char what is the most efficient way to find the first non repeating char
Interested purely functional implementation haskell or F# preffered.
A fairly straightforward use of Data.Set in combination with filter will do the job in an efficient one-liner. Since this seems homeworkish, I'm declining to provide the precise line in question :-)
The complexity should, I think, be O(n log m) where m is the number of distinct characters in the string and n is the total number of characters in the string.
A simple F# solution:
let f (s: string) =
let n = Map(Seq.countBy id s)
Seq.find (fun c -> n.[c] = 1) s
Here's an F# solution in O(n log n): sort the array, then for each character in the original array, binary search for it in the sorted array: if it's the only one of its kind, that's it.
open System
open System.IO
open System.Collections.Generic
let Solve (str : string) =
let arrStr = str.ToCharArray()
let sorted = Array.sort arrStr
let len = str.Length - 1
let rec Inner i =
if i = len + 1 then
'-'
else
let index = Array.BinarySearch(sorted, arrStr.[i])
if index = 0 && sorted.[index+1] <> sorted.[index] then
arrStr.[i]
elif index = len && sorted.[index-1] <> sorted.[index] then
arrStr.[i]
elif index > 0 && index < len &&
sorted.[index+1] <> sorted.[index] &&
sorted.[index-1] <> sorted.[index] then
arrStr.[i]
else
Inner (i + 1)
Inner 0
let _ =
printfn "%c" (Solve "abcdefabcf")
A - means all characters are repeated.
Edit: ugly hack with using the - for "no solution" as you can use Options, which I keep forgetting about! An exercise for the reader, as this does look like homework.
Here's a bit longish solution, but guaranteed to be worst-case O(n log n):
import List
import Data.Ord.comparing
sortPairs :: Ord a => [(a, b)]->[(a, b)]
sortPairs = sortBy (comparing fst)
index :: Integral b => [a] -> [(a, b)]
index = flip zip [1..]
dropRepeated :: Eq a => [(a, b)]->[(a, b)]
dropRepeated [] = []
dropRepeated [x] = [x]
dropRepeated (x:xs) | fst x == fst (head xs) =
dropRepeated $ dropWhile ((==(fst x)).fst) xs
| otherwise =
x:(dropRepeated xs)
nonRepeatedPairs :: Ord a => Integral b => [a]->[(a, b)]
nonRepeatedPairs = dropRepeated . sortPairs . index
firstNonRepeating :: Ord a => [a]->a
firstNonRepeating = fst . minimumBy (comparing snd) . nonRepeatedPairs
The idea is: sort the string lexicographically, so that it's easy to remove any repeated characters in linear time and find the first character which is not repeated. But in order to find it, we need to save information about characters' positions in text.
The speed on easy cases (like [1..10000]) is not perfect, but for something harder ([1..10000] ++ [1..10000] ++ [10001]) you can see the difference between this and a naive O(n^2).
Of course this can be done in linear time, if the size of alphabet is O(1), but who knows how large the alphabet is...
An alternate Haskell O(n log n) solution using Data.Map and no sorting:
module NonRepeat (
firstNonRepeat
)
where
import Data.List (minimumBy)
import Data.Map (fromListWith, toList)
import Data.Ord (comparing)
data Occurance = Occ { first :: Int, count :: Int }
deriving (Eq, Ord)
note :: Int -> a -> (a, Occurance)
note pos a = (a, Occ pos 1)
combine :: Occurance -> Occurance -> Occurance
combine (Occ p0 c0) (Occ p1 c1) = Occ (p0 `min` p1) (c0 + c1)
firstNonRepeat :: (Ord a) => [a] -> Maybe a
firstNonRepeat = fmap fst . findMinimum . occurances
where occurances = toList . fromListWith combine . zipWith note [0..]
findMinimum = safeMinimum . filter ((== 1).count.snd)
safeMinimum [] = Nothing
safeMinimum xs = Just $ minimumBy (comparing snd) xs
let firstNonRepeating (str:string) =
let rec inner i cMap =
if i = str.Length then
cMap
|> Map.filter (fun c (count, index) -> count = 1)
|> Map.toSeq
|> Seq.minBy (fun (c, (count, index)) -> index)
|> fst
else
let c = str.[i]
let value = if cMap.ContainsKey c then
let (count, index) = cMap.[c]
(count + 1, index)
else
(1, i)
let cMap = cMap.Add(c, value)
inner (i + 1) cMap
inner 0 (Map.empty)
Here is a simpler version that sacrifices speed.
let firstNonRepeating (str:string) =
let (c, count) = str
|> Seq.countBy (fun c -> c)
|> Seq.minBy (fun (c, count) -> count)
if count = 1 then Some c else None
How about something like this:
let firstNonRepeat s =
let repeats =
((Set.empty, Set.empty), s)
||> Seq.fold (fun (one,many) c -> Set.add c one, if Set.contains c one then Set.add c many else many)
|> snd
s
|> Seq.tryFind (fun c -> not (Set.contains c repeats))
This is pure C# (so I assume there's a similar F# version), which will be efficient if GroupBy is efficient (which it ought to be):
static char FstNonRepeatedChar(string s)
{
return s.GroupBy(x => x).Where(xs => xs.Count() == 1).First().First();
}
Inspired by this question and answer, how do I create a generic permutations algorithm in F#? Google doesn't give any useful answers to this.
EDIT: I provide my best answer below, but I suspect that Tomas's is better (certainly shorter!)
you can also write something like this:
let rec permutations list taken =
seq { if Set.count taken = List.length list then yield [] else
for l in list do
if not (Set.contains l taken) then
for perm in permutations list (Set.add l taken) do
yield l::perm }
The 'list' argument contains all the numbers that you want to permute and 'taken' is a set that contains numbers already used. The function returns empty list when all numbers all taken.
Otherwise, it iterates over all numbers that are still available, gets all possible permutations of the remaining numbers (recursively using 'permutations') and appends the current number to each of them before returning (l::perm).
To run this, you'll give it an empty set, because no numbers are used at the beginning:
permutations [1;2;3] Set.empty;;
I like this implementation (but can't remember the source of it):
let rec insertions x = function
| [] -> [[x]]
| (y :: ys) as l -> (x::l)::(List.map (fun x -> y::x) (insertions x ys))
let rec permutations = function
| [] -> seq [ [] ]
| x :: xs -> Seq.concat (Seq.map (insertions x) (permutations xs))
Tomas' solution is quite elegant: it's short, purely functional, and lazy. I think it may even be tail-recursive. Also, it produces permutations lexicographically. However, we can improve performance two-fold using an imperative solution internally while still exposing a functional interface externally.
The function permutations takes a generic sequence e as well as a generic comparison function f : ('a -> 'a -> int) and lazily yields immutable permutations lexicographically. The comparison functional allows us to generate permutations of elements which are not necessarily comparable as well as easily specify reverse or custom orderings.
The inner function permute is the imperative implementation of the algorithm described here. The conversion function let comparer f = { new System.Collections.Generic.IComparer<'a> with member self.Compare(x,y) = f x y } allows us to use the System.Array.Sort overload which does in-place sub-range custom sorts using an IComparer.
let permutations f e =
///Advances (mutating) perm to the next lexical permutation.
let permute (perm:'a[]) (f: 'a->'a->int) (comparer:System.Collections.Generic.IComparer<'a>) : bool =
try
//Find the longest "tail" that is ordered in decreasing order ((s+1)..perm.Length-1).
//will throw an index out of bounds exception if perm is the last permuation,
//but will not corrupt perm.
let rec find i =
if (f perm.[i] perm.[i-1]) >= 0 then i-1
else find (i-1)
let s = find (perm.Length-1)
let s' = perm.[s]
//Change the number just before the tail (s') 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] s') > 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] <- s'
//Sort the tail in increasing order.
System.Array.Sort(perm, s+1, perm.Length - s - 1, comparer)
true
with
| _ -> false
//permuation sequence expression
let c = f |> comparer
let freeze arr = arr |> Array.copy |> Seq.readonly
seq { let e' = Seq.toArray e
yield freeze e'
while permute e' f c do
yield freeze e' }
Now for convenience we have the following where let flip f x y = f y x:
let permutationsAsc e = permutations compare e
let permutationsDesc e = permutations (flip compare) e
My latest best answer
//mini-extension to List for removing 1 element from a list
module List =
let remove n lst = List.filter (fun x -> x <> n) lst
//Node type declared outside permutations function allows us to define a pruning filter
type Node<'a> =
| Branch of ('a * Node<'a> seq)
| Leaf of 'a
let permutations treefilter lst =
//Builds a tree representing all possible permutations
let rec nodeBuilder lst x = //x is the next element to use
match lst with //lst is all the remaining elements to be permuted
| [x] -> seq { yield Leaf(x) } //only x left in list -> we are at a leaf
| h -> //anything else left -> we are at a branch, recurse
let ilst = List.remove x lst //get new list without i, use this to build subnodes of branch
seq { yield Branch(x, Seq.map_concat (nodeBuilder ilst) ilst) }
//converts a tree to a list for each leafpath
let rec pathBuilder pth n = // pth is the accumulated path, n is the current node
match n with
| Leaf(i) -> seq { yield List.rev (i :: pth) } //path list is constructed from root to leaf, so have to reverse it
| Branch(i, nodes) -> Seq.map_concat (pathBuilder (i :: pth)) nodes
let nodes =
lst //using input list
|> Seq.map_concat (nodeBuilder lst) //build permutations tree
|> Seq.choose treefilter //prune tree if necessary
|> Seq.map_concat (pathBuilder []) //convert to seq of path lists
nodes
The permutations function works by constructing an n-ary tree representing all possible permutations of the list of 'things' passed in, then traversing the tree to construct a list of lists. Using 'Seq' dramatically improves performance as it makes everything lazy.
The second parameter of the permutations function allows the caller to define a filter for 'pruning' the tree before generating the paths (see my example below, where I don't want any leading zeros).
Some example usage: Node<'a> is generic, so we can do permutations of 'anything':
let myfilter n = Some(n) //i.e., don't filter
permutations myfilter ['A';'B';'C';'D']
//in this case, I want to 'prune' leading zeros from my list before generating paths
let noLeadingZero n =
match n with
| Branch(0, _) -> None
| n -> Some(n)
//Curry myself an int-list permutations function with no leading zeros
let noLZperm = permutations noLeadingZero
noLZperm [0..9]
(Special thanks to Tomas Petricek, any comments welcome)
If you need distinct permuations (when the original set has duplicates), you can use this:
let rec insertions pre c post =
seq {
if List.length post = 0 then
yield pre # [c]
else
if List.forall (fun x->x<>c) post then
yield pre#[c]#post
yield! insertions (pre#[post.Head]) c post.Tail
}
let rec permutations l =
seq {
if List.length l = 1 then
yield l
else
let subperms = permutations l.Tail
for sub in subperms do
yield! insertions [] l.Head sub
}
This is a straight-forward translation from this C# code. I am open to suggestions for a more functional look-and-feel.
Take a look at this one:
http://fsharpcode.blogspot.com/2010/04/permutations.html
let length = Seq.length
let take = Seq.take
let skip = Seq.skip
let (++) = Seq.append
let concat = Seq.concat
let map = Seq.map
let (|Empty|Cons|) (xs:seq<'a>) : Choice<Unit, 'a * seq<'a>> =
if (Seq.isEmpty xs) then Empty else Cons(Seq.head xs, Seq.skip 1 xs)
let interleave x ys =
seq { for i in [0..length ys] ->
(take i ys) ++ seq [x] ++ (skip i ys) }
let rec permutations xs =
match xs with
| Empty -> seq [seq []]
| Cons(x,xs) -> concat(map (interleave x) (permutations xs))
If you need permutations with repetitions, this is the "by the book" approach using List.indexed instead of element comparison to filter out elements while constructing a permutation.
let permutations s =
let rec perm perms carry rem =
match rem with
| [] -> carry::perms
| l ->
let li = List.indexed l
let permutations =
seq { for ci in li ->
let (i, c) = ci
(perm
perms
(c::carry)
(li |> List.filter (fun (index, _) -> i <> index) |> List.map (fun (_, char) -> char))) }
permutations |> Seq.fold List.append []
perm [] [] s