I've run into a small problem here. I wrote the Tortoise and Hare cycle detection algorithm.
type Node =
| DataNode of int * Node
| LastNode of int
let next node =
match node with
|DataNode(_,n) -> n
|LastNode(_) -> failwith "Error"
let findCycle(first) =
try
let rec fc slow fast =
match (slow,fast) with
| LastNode(a),LastNode(b) when a=b -> true
| DataNode(_,a), DataNode(_,b) when a=b -> true
| _ -> fc (next slow) (next <| next fast)
fc first <| next first
with
| _ -> false
This is working great for
let first = DataNode(1, DataNode(2, DataNode(3, DataNode(4, LastNode(5)))))
findCycle(first)
It shows false. Right. Now when try to test it for a cycle, I'm unable to create a loop!
Obviously this would never work:
let first = DataNode(1, DataNode(2, DataNode(3, DataNode(4, first))))
But I need something of that kind! Can you tell me how to create one?
You can't do this with your type as you've defined it. See How to create a recursive data structure value in (functional) F#? for some alternative approaches which would work.
As an alternative to Brian's solution, you might try something like:
type Node =
| DataNode of int * NodeRec
| LastNode of int
and NodeRec = { node : Node }
let rec cycle = DataNode(1, { node =
DataNode(2, { node =
DataNode(3, { node =
DataNode(4, { node = cycle}) }) }) })
Here is one way:
type Node =
| DataNode of int * Lazy<Node>
| LastNode of int
let next node = match node with |DataNode(_,n) -> n.Value |LastNode(_) -> failwith "Error"
let findCycle(first) =
try
let rec fc slow fast =
match (slow,fast) with
| LastNode(a),LastNode(b) when a=b->true
| DataNode(a,_), DataNode(b,_) when a=b -> true
| _ -> fc (next slow) (next <| next fast)
fc first <| next first
with
| _ -> false
let first = DataNode(1, lazy DataNode(2, lazy DataNode(3, lazy DataNode(4, lazy LastNode(5)))))
printfn "%A" (findCycle(first))
let rec first2 = lazy DataNode(1, lazy DataNode(2, lazy DataNode(3, lazy DataNode(4, first2))))
printfn "%A" (findCycle(first2.Value))
Even though both Brian and kvb posted answers that work, I still felt I needed to see if it was possible to achieve the same thing in a different way. This code will give you a cyclic structure wrapped as a Seq<'a>
type Node<'a> = Empty | Node of 'a * Node<'a>
let cyclic (n:Node<_>) : _ =
let rn = ref n
let rec next _ =
match !rn with
| Empty -> rn := n; next Unchecked.defaultof<_>
| Node(v, x) -> rn := x; v
Seq.initInfinite next
let nodes = Node(1, Node(2, Node(3, Empty)))
cyclic <| nodes |> Seq.take 40 // val it : seq<int> = seq [1; 2; 3; 1; ...]
The structure itself is not cyclic, but it looks like it from the outside.
Or you could do this:
//removes warning about x being recursive
#nowarn "40"
type Node<'a> = Empty | Node of 'a * Lazy<Node<'a>>
let rec x = Node(1, lazy Node(2, lazy x))
let first =
match x with
| Node(1, Lazy(Node(2,first))) -> first.Value
| _ -> Empty
Can you tell me how to create one?
There are various hacks to get a directly cyclic value in F# (as Brian and kvb have shown) but I'd note that this is rarely what you actually want. Directly cyclic data structures are a pig to debug and are usually used for performance and, therefore, made mutable.
For example, your cyclic graph might be represented as:
> Map[1, 2; 2, 3; 3, 4; 4, 1];;
val it : Map<int,int> = map [(1, 2); (2, 3); (3, 4); (4, 1)]
The idiomatic way to represent a graph in F# is to store a dictionary that maps from handles to vertices and, if necessary, another for edges. This approach is much easier to debug because you traverse indirect recursion via lookup tables that are comprehensible as opposed to trying to decipher a graph in the heap. However, if you want to have the GC collect unreachable subgraphs for you then a purely functional alternative to a weak hash map is apparently an unsolved problem in computer science.
Related
This is a question that extends F# Recursive Tree Validation, which I had nicely answered yesterday.
This question concerns inserting a child in an existing tree. This is the updated type I'd like to use:
type Name = string
type BirthYear = int
type FamilyTree = Person of Name * BirthYear * Children
and Children = FamilyTree list
My last question concerned checking the validity of the tree, this was the solution I decided to go with:
let rec checkAges minBirth = function
| Person(_,b,_) :: t -> b >= minBirth && checkAges b t
| [] -> true
let rec validate (Person(_,b,c)) =
List.forall isWF c && checkAges (b + 16) c
Now I would like to be able to insert a Person Simon as a child of specific Person Hans in the following form
insertChildOf "Hans" simon:Person casperFamily:FamilyTree;;
So, input should be parent name, child and the family tree. Ideally it should then return a modified family tree, that is FamilyTree option
What I am struggling with is to incorporating the validate function to make sure it is legal, and a way to insert it properly in the list of children, if the insertion Person is already a parent - maybe as a seperate function.
All help is welcome and very appreciated - thanks! :)
After your comment here's a code that will behave as expected:
let insert pntName (Person(_, newPrsnYear, _) as newPrsn) (Person (n,y,ch)) =
let rec ins n y = function
| [] -> if y < newPrsnYear && n = pntName then Some [newPrsn] else None
| (Person (name, year, childs) as person) :: bros ->
let tryNxtBros() = Option.map (fun x -> person::x) (ins n y bros)
if y < newPrsnYear && n = pntName then // father OK
if newPrsnYear < year then // brother OK -> insert here
Some (newPrsn::person::bros)
else tryNxtBros()
else // keep looking, first into eldest child ...
match ins name year childs with
| Some i -> Some (Person (name, year, i) :: bros)
| _ -> tryNxtBros() // ... then into other childs
Option.map (fun x -> Person (n, y, x)) (ins n y ch)
As in my previous answer I keep avoiding using List functions since I don't think they are a good fit in a tree structure unless the tree provides a traverse.
I might be a bit purist in the sense I use either List functions (with lambdas and combinators) or pure recursion, but in general I don't like mixing them.
This is a follow up to my previous question about processing a Vector representation of a 5.1m edge directed graph. I am trying to implement Kosaraju's graph algorithm and thus need to rearrange my Vector in the order of the finishing times of a depth first search (DFS) on the edges reversed. I have code that runs on small data sets but that fails to return in 10 minutes on the full data set. (I can't exclude that a loop arises from the big graph, but there are no signs of that on my test data.)
DFS needs to avoid revisiting nodes, so I need some sort of 'state' for the search (currently a tuple, should I use a State Monad?). The first search should return a reordered Vector, but I am keeping things simple at present by returning a list of the reordered Node indexes so that I can process the Vector in one go subsequently.
I presume the issue lies in dfsInner. The code below 'remembers' the nodes visited updating the explored field of each node (third guard). Although I tried to make it tail recursive, the code seems to grow memory use fairly fast. Do I need to enforce some strictness and if so, how? (I have another version that I use on a single search search, which checks for previous visits by looking at the start nodes of the unexplored edges on the stack and the list of nodes that have been completed. This does not grow so quickly, but does not return for any well connected node.)
However, it could also be the foldr', but how can I detect that?
This is supposedly Coursera homework, but I'm no longer sure I can tick the honour code button! Learning is more important though, so I don't really want a copy/paste answer. What I have is not very elegant - it has an imperative feel to it too, which is driven by the issue with keeping some sort of state - see third guard. I'd welcome comments on design patterns.
type NodeName = Int
type Edges = [NodeName]
type Explored = Bool
type Stack = [(Int, Int)]
data Node = Node NodeName Explored Edges Edges deriving (Eq, Show)
type Graph = Vector Node
main = do
edges <- V.fromList `fmap` getEdges "SCC.txt"
let
maxIndex = fst $ V.last edges
gr = createGraph maxIndex edges
res = dfsOuter gr
--return gr
putStrLn $ show res
dfsOuter gr =
let tmp = V.foldr' callInner (gr,[]) gr
in snd tmp
callInner :: Node -> (Graph, Stack) -> (Graph, Stack)
callInner (Node idx _ fwd bwd) (gr,acc) =
let (Node _ explored _ _) = gr V.! idx
in case explored of
True -> (gr, acc)
False ->
let
initialStack = map (\l -> (idx, l)) bwd
gr' = gr V.// [(idx, Node idx True fwd bwd)]
(gr'', newScc) = dfsInner idx initialStack (length acc) (gr', [])
in (gr'', newScc++acc)
dfsInner :: NodeName -> Stack -> Int -> (Graph, [(Int, Int)]) -> (Graph, [(Int, Int)])
dfsInner start [] finishCounter (gr, acc) = (gr, (start, finishCounter):acc)
dfsInner start stack finishCounter (gr, acc)
| nextStart /= start = -- no more places to go from this node
dfsInner nextStart stack (finishCounter + 1) $ (gr, (start, finishCounter):acc)
| nextExplored =
-- nextExplored || any (\(y,_) -> y == stack0Head) stack || any (\(x,_) -> x == stack0Head) acc =
dfsInner start (tail stack) finishCounter (gr, acc)
| otherwise =
dfsInner nextEnd (add2Stack++stack) finishCounter (gr V.// [(nextEnd, Node idx True nextLHS nextRHS)], acc)
-- dfsInner gr stack0Head (add2Stack++stack) finishCounter acc
where
(nextStart, nextEnd) = head stack
(Node idx nextExplored nextLHS nextRHS) = gr V.! nextEnd
add2Stack = map (\l -> (nextEnd, l)) nextRHS
In a nutshell:
Know the time complexities.
There are a lot of fine points to optimization, a large subset of which being not very important in everyday programming, but fail to know the asymptotic complexities and programs will often just not work at all.
Haskell libraries usually document the complexities, especially when it's not obvious or not effective (linear of worse). In particular, all the complexities relevant to this question can be found in Data.List and Data.Vector.
The performance is killed by V.// here. Vectors are boxed or unboxed immutable contiguous arrays in memory. Hence, modifying them requires copying the entire vector. Since we have O(N) such modifications, the whole algorithm is O(n^2), so we have to copy about 2 terabytes with N = 500000. So, there isn't much use for marking visited nodes inside the vector. Instead, build an IntSet of indices as needed.
initialStack (length acc) also looks really bad. It's almost never a good idea to use length on large lists, because it's also O(n). It's probably not as nearly as bad as // in your code, since it sits in a relatively rarely occurring branch, but it'd still leave the performance crippled after we've corrected the vector issue.
Also, the search implementation seems rather unclear and overcomplicated to me. Aiming for a literal-minded translation of the pseudocode on the Wiki page should be a good start. Also, it's unnecessary to store the indices in nodes, since they can be determined from vector positions and the adjacency lists.
Based on #andras gist, I rewrote my code as below. I did not use Arrow functions as I am unfamiliar with them, and my second depth first search is stylistically the same as the first one (instead of #Andras filterM approach). The end result is that it completes in 20% of the time of Andras' code (21s instead of 114s).
import qualified Data.Vector as V
import qualified Data.IntSet as IS
import qualified Data.ByteString.Char8 as BS
import Data.List
import Control.Monad
import Control.Monad.State
--import Criterion.Main
--getEdges :: String -> IO [(Int, Int)]
getEdges file = do
lines <- (map BS.words . BS.lines) `fmap` BS.readFile file
let
pairs = (map . map) (maybe (error "can't read Int") fst . BS.readInt) lines
pairs' = [(a, b) | [a, b] <- pairs] -- adds 9 seconds
maxIndex = fst $ last pairs'
graph = createGraph maxIndex pairs'
return graph
main = do
graph <- getEdges "SCC.txt"
--let
--maxIndex = fst $ V.last edges
let
fts = bwdLoop graph
leaders = fst $ execState (fwdLoop graph fts) ([], IS.empty)
print $ length leaders
type Connections = [Int]
data Node = Node {fwd, bwd :: Connections} deriving (Show)
type Graph = V.Vector Node
type Visited = IS.IntSet
type FinishTime = Int
type FinishTimes = [FinishTime]
type Leaders = [Int]
createGraph :: Int -> [(Int, Int)] -> Graph
createGraph maxIndex pairs =
let
graph = V.replicate (maxIndex+1) (Node [] [])
graph' = V.accum (\(Node f b) x -> Node (x:f) b) graph pairs
in V.accum (\(Node f b) x -> Node f (x:b)) graph' $ map (\(a,b) -> (b,a)) pairs
bwdLoop :: Graph -> FinishTimes
bwdLoop g = fst $ execState (mapM_ go $ reverse [0 .. V.length g - 1]) ([], IS.empty) where
go :: Int -> State (FinishTimes, Visited) ()
go i = do
(fTimes, vs) <- get
let visited = IS.member i vs
if not visited then do
put (fTimes, IS.insert i vs)
mapM_ go $ bwd $ g V.! i
-- get state again after changes from mapM_
(fTimes', vs') <- get
put (i : fTimes', vs')
else return ()
fwdLoop :: Graph -> FinishTimes -> State (Leaders, Visited) ()
fwdLoop _ [] = return ()
fwdLoop g (i:fts) = do
(ls, vs) <- get
let visited = IS.member i vs
if not visited then do
put (i:ls, IS.insert i vs)
mapM_ go $ fwd $ g V.! i
else return ()
fwdLoop g fts
where
go :: Int -> State (Leaders, Visited) ()
go i = do
(ls, vs) <- get
let visited = IS.member i vs
if not visited then do
put (ls, IS.insert i vs)
mapM_ go $ fwd $ g V.! i
else return ()
I am pretty new to F# and I wanted to implement a solution to the following problem:
From a sequence of disk paths discovered in random order (e.g. "C:\Hello\foo" "C:" , "C:\Hello\bar" etc....) how to build (efficiently) the tree.
Assumption: the sequence is valid, which means the tree can be effectively created.
So I tried to implement with a recursive function ("mergeInto" in the following) which merges the tree "in place" with a list of string (the splitted path called "branch")
Here is my implementation, the immutability prevents side effects on the input tree, so I tried to use a ref cell for the input Tree but I encounter difficulty with the recursion. Any solution ?
open Microsoft.VisualStudio.TestTools.UnitTesting
type Tree =
|Node of string*list<Tree>
|Empty
let rec branchToTree (inputList:list<string>) =
match inputList with
| [] -> Tree.Empty
| head::tail -> Tree.Node (head, [branchToTree tail])
//branch cannot be empty list
let rec mergeInto (tree:Tree ref) (branch:list<string>) =
match !tree,branch with
| Node (value,_), head::tail when String.op_Inequality(value, head) -> raise (ApplicationException("Oops invariant loop broken"))
| Node (value,_), [_] -> ignore() //the branch is singleton and by loop invariant its head is the current Tree node -> nothing to do.
| Node (value,children), _ ->
let nextBranchValue = branch.Tail.Head //valid because of previous match
//broken attempt to retrieve a ref to the proper child
let targetChild = children
|> List.map (fun(child) -> ref child)
|> List.tryFind (fun(child) -> match !child with
|Empty -> false
|Node (value,_) -> value = nextBranchValue)
match targetChild with
|Some x -> mergeInto x branch.Tail //a valid child match then go deeper. NB: branch.Tail cannot be empty here
|None -> tree := Node(value, (Node (nextBranchValue,[])) :: children)//attach the next branch value to the children
| Empty,_ -> tree := branchToTree branch
[<TestClass>]
type TreeTests () =
[<TestMethod>]
member this.BuildTree () =
let initialTree = ref Tree.Empty
let branch1 = ["a";"b";"c"]
let branch2 = ["a";"b";"d"]
do mergeInto initialTree branch1
//-> my tree is ok
do mergeInto initialTree branch2
//->not ok, expected a
// |
// b
// / \
// d c
You can't make a ref to an element in a list, change the ref and then expect the item in the list to change. If you really want to do that then you should put the references into your Tree type.
type Tree =
|Node of string*list<Tree ref>
|Empty
let rec branchToTree (inputList:list<string>) =
match inputList with
| [] -> Tree.Empty
| head::tail -> Tree.Node(head, [ref (branchToTree tail)])
If you do that, remove the List.map (fun(child) -> ref child) part then your code works.
You might be interested in zippers which allow you to do something similar but without mutation.
I want to implement search using BFS. The Algorithm say that i must use a queue to get FIFO effect.
I read Chris Okasaki's Purely Functional Data Structures book and found how to make a queue (i wrote using F#) :
type 'a queue = 'a list * 'a list
let emtpy = [],[]
let isEmpty = function
| [],_ -> true
| _ -> false
let checkf = function
| [],r -> List.rev r,[]
| q -> q
let snoc (f,r) x = checkf (f,x :: r)
let head = function
| ([],_) -> failwith "EMPTY"
| (x::f,r) -> x
let tail = function
| ([],_) -> failwith "EMPTY"
| (x::f,r) -> checkf (f,r)
anyone know how to implement this to BFS?
and i have this code to make a tree from a list:
let data = [4;3;8;7;10;1;9;6;5;0;2]
type Tree<'a> =
| Node of Tree<'a> * 'a * Tree<'a>
| Leaf
let rec insert tree element =
match element,tree with
| x,Leaf -> Node(Leaf,x,Leaf)
| x,Node(l,y,r) when x <= y -> Node((insert l x),y,r)
| x,Node(l,y,r) when x > y -> Node(l,y,(insert r x))
| _ -> Leaf
let makeTree = List.fold insert Leaf data
(want to combine these two codes)
the BFS algorithm is this:
Initialise the search by placing the starting vertex in the queue.
While the queue is not empty.
Remove the front vertex from the queue.
If this is a solution then we're finished -- report success.
Otherwise, compute the immediate children of this vertex and enqueue them.
Otherwise we have exhausted the queue and found no solution -- report failure.
My F# syntax is a bit wobbly, but here's how I'd sketch out the solution:
bfs start = bfsLoop ([start], [])
bfsLoop q0 =
if isEmpty q0
then failWith "No solution"
else v = head q0
if isSolution v
then v
else q1 = tail q0
vs = childrenOf v
q = foldl snoc vs q1
bfsLoop q
Hope this helps.
Might still be useful 11 years later?
BFS in F# is not hard: Instead of a while loop you can use recursion to keep it mutable-free.
I enqueue each node with its trace so we can calculate the solution path.
let data = [4;3;8;7;10;1;9;6;5;0;2]
type Tree<'a> =
| Node of Tree<'a> * 'a * Tree<'a>
| Leaf
let rec insert tree element =
match element,tree with
| x,Leaf -> Node(Leaf,x,Leaf)
| x,Node(l,y,r) when x <= y -> Node((insert l x),y,r)
| x,Node(l,y,r) when x > y -> Node(l,y,(insert r x))
| _ -> Leaf
let tree = List.fold insert Leaf data
// BFS
let rec find goal queue =
match queue with
| [] -> None
| (Leaf, _)::tail -> find goal tail
| (Node (l,y,r), trace)::tail ->
if y = goal then Some (List.rev (y::trace)) else
find goal (tail # [ l, y::trace; r, y::trace ])
// for example, to find the 5 in your tree
find 5 [tree, []]
|> printfn "%A"
// it will return: Some [4; 8; 7; 6; 5]
// because your tree looks like this:
// 4
// / \
// 3 8
// / / \
// 1 7 10
// / \ / /
// 0 2 6 9
// /
// 5
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