I made a splay tree, but I don't understand how to delete min element from it, can someone help please?
data Splay a = Empty | Node a (Splay a) (Splay a) deriving Show
data Direction = L | R deriving Eq
rotate :: Direction -> Splay a -> Splay a
rotate L (Node x a (Node y b c)) = (Node y (Node x a b) c)
rotate R (Node y (Node x a b) c) = (Node x a (Node y b c))
insert :: Ord a => a -> Splay a -> Splay a
insert x t = let (path, t') = pathToInserted x t in splay t' path
where pathToInserted :: Ord a => a -> Splay a -> ([Direction], Splay a)
pathToInserted x Empty = ([], Node x Empty Empty)
pathToInserted x t#(Node val l r)
| x == val = ([], t)
| x < val = let (path,l') = pathToInserted x l in (L:path, Node val l' r)
| x > val = let (path,r') = pathToInserted x r in (R:path, Node val l r')
splay :: Splay a -> [Direction] -> Splay a
splay t [] = t
-- Zig
splay t [L] = rotate R t
splay t [R] = rotate L t
-- Zig-zig
splay (Node q (Node p x c) d) (L:L:path) =
rotate R $ rotate R (Node q (Node p (splay x path) c) d)
splay (Node p a (Node q b x)) (R:R:path) =
rotate L $ rotate L (Node p a (Node q b (splay x path)))
-- Zig-zag
splay (Node q (Node p a x) d) (L:R:path) =
rotate R (Node q (rotate L $ Node p a (splay x path)) d)
splay (Node p a (Node q x d)) (R:L:path) =
rotate L (Node p a (rotate R $ Node q (splay x path) d))
fromList :: Ord a => [a] -> Splay a
fromList = foldr insert Empty
insert' :: Ord a => a -> Splay a -> Splay a
insert' x Empty = Node x Empty Empty
insert' x t#(Node val l r)
| x == val = t
| x < val = rotate R (Node val (insert' x l) r)
| x > val = rotate L (Node val l (insert' x r))
main :: IO()
main = putStrLn . show $ fromList [8,3,10,1,6,4,7,14,13]
Splay the leftmost element and return its right child. You'll need a helper like pathToInserted to return a list of Ls of the proper length.
Related
I want to prove that when receiving a binary search tree as an argument, the [insert] function generates another binary search tree.
Insert Function:
Fixpoint insert {V : Type} (x : key) (v : V) (t : tree V) : tree V :=
match t with
| E => T E x v E
| T l y v' r => if x <? y then T (insert x v l) y v' r
else if x >? y then T l y v' (insert x v r)
else T l x v r
end.
I have written the following proof. However I am stuck in the middle of the proof.
I can see what I have to proove BST (T t1 k v t2), but I am unable to proceed by applying the hypothesis H : BST (T t1 k0 v0 t2)...
What can I do next in order to proove that
Theorem insert_BST : forall (V : Type) (k : key) (v : V) (t : tree V),
BST t -> BST (insert k v t).
Proof.
intros V k v t.
induction t; intros H.
- simpl. apply BST_T.
+ simpl. constructor.
+ simpl. constructor.
+ constructor.
+ constructor.
- inversion H; subst.
simpl in *.
bdestruct (k0 >? k).
+ apply BST_T.
* apply ForallT_insert.
apply H4.
apply H0.
* apply H5.
* apply IHt1.
apply H6.
* apply H7.
+ bdall.
** constructor. apply H4.
* apply ForallT_insert.
assumption.
assumption.
*apply H6.
* apply IHt2 in H7.
apply H7.
** constructor; apply H.
The whole code is here down below:
From Coq Require Import String.
From Coq Require Export Arith.
From Coq Require Export Lia.
Notation "a >=? b" := (Nat.leb b a) (at level 70) : nat_scope.
Notation "a >? b" := (Nat.ltb b a) (at level 70) : nat_scope.
Definition key := nat.
Inductive tree (V : Type) : Type :=
| E
| T (l : tree V) (k : key) (v : V) (r : tree V).
Arguments E {V}.
Arguments T {V}.
Definition empty_tree {V : Type} : tree V := E.
Fixpoint bound {V : Type} (x : key) (t : tree V) :=
match t with
| E => false
| T l y v r => if x <? y then bound x l
else if x >? y then bound x r
else true
end.
Fixpoint lookup {V : Type} (d : V) (x : key) (t : tree V) : V :=
match t with
| E => d
| T l y v r => if x <? y then lookup d x l
else if x >? y then lookup d x r
else v
end.
Fixpoint insert {V : Type} (x : key) (v : V) (t : tree V) : tree V :=
match t with
| E => T E x v E
| T l y v' r => if x <? y then T (insert x v l) y v' r
else if x >? y then T l y v' (insert x v r)
else T l x v r
end.
(** Nossa primeira tarefa será mostrar que a função [insert] de fato preserva esta invariante. Vamos então formalizar a invariante de uma árvore binária de busca. Faremos isto com a ajuda da função [ForallT]: *)
Fixpoint ForallT {V : Type} (P: key -> V -> Prop) (t: tree V) : Prop :=
match t with
| E => True
| T l k v r => P k v /\ ForallT P l /\ ForallT P r
end.
Inductive BST {V : Type} : tree V -> Prop :=
| BST_E : BST E
| BST_T : forall l x v r,
ForallT (fun y _ => y < x) l ->
ForallT (fun y _ => y > x) r ->
BST l ->
BST r ->
BST (T l x v r).
Hint Constructors BST.
Ltac inv H := inversion H; clear H; subst.
Inductive reflect (P : Prop) : bool -> Set :=
| ReflectT : P -> reflect P true
| ReflectF : ~ P -> reflect P false.
Theorem iff_reflect : forall P b, (P <-> b = true) -> reflect P b.
Proof.
intros P b H. destruct b.
- apply ReflectT. rewrite H. reflexivity.
- apply ReflectF. rewrite H. intros H'. inversion H'.
Qed.
Theorem reflect_iff : forall P b, reflect P b -> (P <-> b = true).
Proof.
intros P b H; split.
- intro H'.
inv H.
+ reflexivity.
+ contradiction.
- intro H'; subst.
inv H; assumption.
Qed.
Lemma eqb_reflect : forall x y, reflect (x = y) (x =? y).
Proof.
intros x y. apply iff_reflect. symmetry.
apply Nat.eqb_eq.
Qed.
Lemma ltb_reflect : forall x y, reflect (x < y) (x <? y).
Proof.
intros x y. apply iff_reflect. symmetry.
apply Nat.ltb_lt.
Qed.
Lemma leb_reflect : forall x y, reflect (x <= y) (x <=? y).
Proof.
intros x y. apply iff_reflect. symmetry.
apply Nat.leb_le.
Qed.
Hint Resolve ltb_reflect leb_reflect eqb_reflect : bdestruct.
Ltac bdestruct X :=
let H := fresh in let e := fresh "e" in
evar (e: Prop);
assert (H: reflect e X); subst e;
[eauto with bdestruct
| destruct H as [H|H];
[ | try first [apply not_lt in H | apply not_le in H]]].
Theorem empty_tree_BST : forall (V : Type),
BST (#empty_tree V).
Proof.
unfold empty_tree.
constructor;try lia.
Qed.
Lemma ForallT_insert : forall (V : Type) (P : key -> V -> Prop) (t : tree V),
ForallT P t -> forall (k : key) (v : V),
P k v -> ForallT P (insert k v t).
Proof.
intros V P t.
induction t; intros H k' v' Pkv.
- simpl. auto.
- simpl in *.
destruct H as [H1 [H2 H3]].
bdestruct (k >? k').
+ simpl. repeat split.
* assumption.
* apply (IHt1 H2 k' v' Pkv).
* assumption.
+ bdestruct (k' >? k).
++ simpl. repeat split.
* assumption.
* assumption.
* apply (IHt2 H3 k' v' Pkv).
++ simpl. repeat split.
* assumption.
* assumption.
* assumption.
Qed.
Ltac bdestruct_guard :=
match goal with
| |- context [ if ?X =? ?Y then _ else _ ] => bdestruct (X =? Y)
| |- context [ if ?X <=? ?Y then _ else _ ] => bdestruct (X <=? Y)
| |- context [ if ?X <? ?Y then _ else _ ] => bdestruct (X <? Y)
end.
Ltac bdall :=
repeat (simpl; bdestruct_guard; try lia; auto).
Theorem insert_BST : forall (V : Type) (k : key) (v : V) (t : tree V),
BST t -> BST (insert k v t).
Proof.
intros V k v t.
induction t; intros H.
- simpl. apply BST_T.
+ simpl. constructor.
+ simpl. constructor.
+ constructor.
+ constructor.
- inversion H; subst.
simpl in *.
bdestruct (k0 >? k).
+ apply BST_T.
* apply ForallT_insert.
apply H4.
apply H0.
* apply H5.
* apply IHt1.
apply H6.
* apply H7.
+ bdall.
** constructor. apply H4.
* apply ForallT_insert.
assumption.
assumption.
*apply H6.
* apply IHt2 in H7.
apply H7.
**
The shortest way to complete your proof may be (just at your last **):
** assert (k = k0) by auto with arith; subst.
inversion_clear H; now constructor.
Qed.
(the second line replaces the lemma BST_irrel of my previous post)
Indeed, you were very close to the Qed! Quite often, if some conclusion looks difficult to prove, it may be useful to look at the context. If you are lucky, you may find a contradiction and it's done. Otherwise, you can try to do a few forward-reasoning steps (like infering k=k0 in your example, and replace k with k0in appropriate occurrences).
Pierre
In your last goal, you have k0 = k (by H0and H1), and you know T t1 k0 v0 t2 is a search tree.
H : BST (T t1 k0 v0 t2)
H0 : k >= k0
H1 : k0 >= k
============================
BST (T t1 k v t2)
So, you may replace kwith k0 in the conclusion. If you prove
that the value v is irrelevant for T l k v r's searchness (a small lemma to prove), your proof is almost completed.
Lemma BST_irrel {V: Type} : forall l r k (v w:V),
BST (T l k v r) -> BST (T l k w r).
Proof. inversion 1; now constructor. Qed.
I'm trying to prove that inverting a binary tree twice produces the same binary tree.
So I have written the following inductive type:
Inductive tree : Type :=
| Leaf (x : Type)
| Node (t1 : tree) (t2 : tree).
And here's the inversion function:
Fixpoint invertTree (t : tree) :=
match t with
| Leaf x => Leaf x
| Node l r => Node (invertTree r) (invertTree l)
end.
The theorem is pretty simple:
Theorem involution_of_invert : forall t : tree,
(invertTree (invertTree t)) = t.
The base case is pretty easy to prove, we start with a proof by induction and just compute -> reflexivity. I'm having a hard time understanding the induction step. Here's as far as I got:
Proof.
induction t.
compute.
reflexivity.
induction t1, t2.
compute.
reflexivity.
And my remaining goals:
3 subgoals (ID 57)
x : Type
t2_1, t2_2 : tree
IHt1 : invertTree (invertTree (Leaf x)) = Leaf x
IHt2 : invertTree (invertTree (Node t2_1 t2_2)) = Node t2_1 t2_2
============================
invertTree (invertTree (Node (Leaf x) (Node t2_1 t2_2))) =
Node (Leaf x) (Node t2_1 t2_2)
subgoal 2 (ID 74) is:
invertTree (invertTree (Node (Node t1_1 t1_2) (Leaf x))) =
Node (Node t1_1 t1_2) (Leaf x)
subgoal 3 (ID 81) is:
invertTree (invertTree (Node (Node t1_1 t1_2) (Node t2_1 t2_2))) =
Node (Node t1_1 t1_2) (Node t2_1 t2_2)
Would be glad if any hint could be provided. I'm pretty new to Coq (as should be pretty clear from the question heh).
Thanks
Found a solution to this, here it is:
Inductive tree : Type :=
| Leaf (x : Type)
| Node (t1 : tree) (t2 : tree).
Fixpoint invertTree (t : tree) :=
match t with
| Leaf x => Leaf x
| Node l r => Node (invertTree r) (invertTree l)
end.
Theorem involution_of_invert : forall t : tree,
(invertTree (invertTree t)) = t.
Proof.
induction t.
compute.
reflexivity.
simpl.
rewrite -> IHt1.
rewrite -> IHt2.
reflexivity.
Qed.
I'm studying Floyd-Warshall algorithm. Now having managed to implement it in Haskell, the way I implement it is similar to how it is implemented in imperative languages (that is to say, use list of lists to simulate 2D arrays), but this is really inefficient giving that accessing an element in a list is much more slower than in a array.
Is there a smarter way to do this in Haskell? I thought I could do this by concate some lists but keep failing.
My Code:
floydwarshall :: [[Weight]] -> [[Weight]]
floydwarshall lst = fwAlg 1 $ initMatrix 0 $ list2matrix lst
fwAlg :: Int -> [[Weight]] -> [[Weight]]
fwAlg k m | k < rows m = let n = rows m
m' = foldl (\m (i,j) -> updateDist i j k m) m [(i,j) | i <- [0..n-1], j <- [0..n-1]]
in fwAlg (k+1) m'
| otherwise = m
-- a special case where k is 0
initMatrix :: Int -> [[Weight]] -> [[Weight]]
initMatrix n m = if n == rows m then m else initMatrix (n+1) $ updateAtM 0.0 (n,n) m
updateDist :: Int -> Int -> Int -> [[Weight]] -> [[Weight]]
updateDist i j k m =
let w = min (weight i j m) (weight i k m + weight k j m)
in updateAtM w (i, j) m
weight :: Vertice -> Vertice -> [[Weight]] -> Weight
weight i j m = let Just w = elemAt (i, j) m in w
The algorithm has a regular access pattern so we can avoid a lot of
indexing and still write it with lists, with (I think) the same
asymptotic performance as the imperative version.
If you do want to use arrays for more speed, you might still want to do
something similar to this with bulk operations on rows and columns
rather than reading and writing individual cells.
-- Let's have a type for weights. We could use Maybe but the ordering
-- behaviour is wrong - when there's no weight it should be like
-- +infinity.
data Weight = Weight Int | None deriving (Eq, Ord, Show)
addWeights :: Weight -> Weight -> Weight
addWeights (Weight x) (Weight y) = Weight (x + y)
addWeights _ _ = None
-- the main function just steps the matrix a number of times equal to
-- the node count. Also pass along k at each step.
floydwarshall :: [[Weight]] -> [[Weight]]
floydwarshall m = snd (iterate step (0, m) !! length m)
-- step takes k and the matrix for k, returns k+1 and the matrix for
-- k+1.
step :: (Int, [[Weight]]) -> (Int, [[Weight]])
step (k, m) = (k + 1, zipWith (stepRow ktojs) istok m)
where
ktojs = m !! k -- current k to each j
istok = transpose m !! k -- each i to current k
-- Make shortest paths from one i to all j.
-- We need the shortest paths from the current k to all j
-- and the shortest path from this i to the current k
-- and the shortest paths from this i to all j
stepRow :: [Weight] -> Weight -> [Weight] -> [Weight]
stepRow ktojs itok itojs = zipWith stepOne itojs ktojs
where
stepOne itoj ktoj = itoj `min` (itok `addWeights` ktoj)
-- example from wikipedia for testing
test :: [[Weight]]
test = [[Weight 0, None, Weight (-2), None],
[Weight 4, Weight 0, Weight 3, None],
[None, None, Weight 0, Weight 2],
[None, Weight (-1), None, Weight 0]]
I don't know how to achieve peak performance, but I can give you some tips on making your code abstract so that you can work on performance tuning more easily.
First of all, it would be nice if, when you change around your data types, you don't have to rewrite everything. Right now, you've made everything concretely about lists of lists, so let's see if we can abstract that out. First, we have to figure out what your minimal matrix interface is. Glancing at your code, you appear to have initMatrix, list2matrix, rows, elemAt, and updateAtM. These are the functions that query or modify your matrix, and these are what you would need to implement to make a new version of this code for a different Matrix type.
One way to organize this interface is to make a class out of it. For instance:
class Matrix m where
list2matrix :: [[a]] -> m a
matrix2List :: m a -> [[a]]
rows :: m a -> Int
elemAt :: Int -> Int -> m a -> a
updateAtM :: a -> (Int, Int) -> m a -> m a
setDiag :: a -> m a -> m a
(I went ahead and added a matrix2List function for extracting your result and renamed/modified initMatrix into setDiag, which felt a little more general.)
We can then update your code to use this new class:
floydwarshall :: Matrix m => [[Weight]] -> m Weight
floydwarshall lst = fwAlg 1 $ initMatrix $ list2matrix lst
fwAlg :: Matrix m => Int -> m Weight -> m Weight
fwAlg k m | k < rows m = let n = rows m
m' = foldl (\m (i,j) -> updateDist i j k m) m [(i,j) | i <- [0..n-1], j <- [0..n-1]]
in fwAlg (k+1) m'
| otherwise = m
initMatrix :: Matrix m => m Weight -> m Weight
initMatrix = setDiag 0
updateDist :: Matrix m => Int -> Int -> Int -> m Weight -> m Weight
updateDist i j k m =
let w = min (elemAt i j m) (elemAt i k m + elemAt k j m)
in updateAtM w (i, j) m
dist :: Matrix m => Int -> Int -> Int -> m Weight -> Weight
dist i j 0 m = elemAt i j m
dist i j k m = min (dist i j (k-1) m) (dist i k (k-1) m + dist k j (k-1) m)
Now all we need to do is start defining some Matrix types and see how performance is!
Let's start with lists, since you've already done this work. We'll have to use a newtype wrapper to make GHC happy, but ignoring the wrapping and unwrapping, this is morally the same as the code you wrote:
newtype ListMatrix a = ListMatrix { getListMatrix :: [[a]] }
instance Matrix ListMatrix where
list2matrix = ListMatrix
matrix2List = getListMatrix
rows = length . getListMatrix
elemAt i j (ListMatrix m) = m !! i !! j
updateAtM a (i,j) (ListMatrix m) =
let (firstRows, row:laterRows) = splitAt i m
(firstCols, _:laterCols) = splitAt j row
in ListMatrix $ firstRows <> ((firstCols <> (a:laterCols)):laterRows)
setDiag x = go 0
where go n m = if n == rows m then m else go (n+1) $ updateAtM x (n,n) m
(Also, I filled in elemAt and updateAtM.) You should be able to run
matrix2List #ListMatrix $ floydwarshall myList
and get the same result (and performance) that you currently have.
Now, on to the experimentation! All that's necessary is for us to define new instances of Matrix and see what happens. Perhaps we should try pure functions:
data FunMatrix a = FunMatrix { size :: Int, getFunMatrix :: Int -> Int -> a }
instance Matrix FunMatrix where
list2matrix l = FunMatrix (length l) (\i j -> l !! i !! j)
matrix2List (FunMatrix s f) = (\i -> f i <$> [0..s-1]) <$> [0..s-1]
rows = size
elemAt i j m = getFunMatrix m i j
updateAtM a (i,j) (FunMatrix s f) = FunMatrix s (\i' j' -> if i==i' && j==j' then a else f i' j')
setDiag x (FunMatrix s f) = FunMatrix s (\i j -> if i==j then x else f i j)
How does that perform? One problem is that the starting lookup function is still just indexing into the list of lists, which is slow. One fix would be to convert to an array or vector first and then index. Because we've nicely abstracted everything, all that would need to change is the definition of list2matrix right here, and you'll probably get a nice performance boost!
On the topic of performance, there's one other note I can point out. The definition of dist does some serious "dynamic programming". This could work fine if you were writing and reading directly into an array, but in this recursive form, you may end up doing a lot of duplicate work. One fix is to memoize. My goto memoization package is MemoTrie, which makes it really easy to memoize things. In this case, you could change dist to:
dist :: Matrix m => m Weight -> Int -> Int -> Int -> Weight
dist m = go'
where
go' = memo3 go
go i j 0 = elemAt i j m
go i j k = min (go' i j (k-1)) (go' i k (k-1) + go' k j (k-1))
That might give you a bit of a boost!
You might consider taking #Chi's advice and use STUArray, but you'll run into a problem: the STUArray interface demands that array lookups are in a monad. It's still possible to use the abstraction method I show off above, but you'll have to change the types of the functions. And, because you change the types in the interface, you'll need to update your algorithm code to be monadic. It can be a bit of a pain, but it might be necessary to get optimal performance.
Imagine an array that associate numbers and words. Exactly one number for one word and vice versa.
dic = [0: 'food',
1: 'dinner',
2.5: 'breakfast',
...]
Now I want to access dic[0] and get food and something['food'] and get 0. Is there any kind of reversible hashtable in the wild ? As far as I know only doing a duplicate can solve this problem.
Yes, this is generally done by combining two maps. Modifications are a bit tricky, because they have to maintain the one-to-one rule.
Let's start with a class for finite maps, and a couple sample instances for containers types:
{-# LANGUAGE
FunctionalDependencies
, FlexibleInstances
, UndecidableInstances
, GeneralizedNewtypeDeriving #-}
module Mappy where
import Prelude hiding (lookup)
-- Example base maps
import qualified Data.Map.Strict as M
import Data.Map (Map)
import qualified Data.IntMap.Strict as IM
import Data.IntMap (IntMap)
class Mappy k v m | m -> k v where
empty :: m
insert :: k -> v -> m -> m
delete :: k -> m -> m
lookup :: k -> m -> Maybe v
instance Ord k => Mappy k a (Map k a) where
empty = M.empty
insert = M.insert
delete = M.delete
lookup = M.lookup
instance Mappy Int a (IntMap a) where
empty = IM.empty
insert = IM.insert
delete = IM.delete
lookup = IM.lookup
Now we can build our type for bidirectional maps:
data Bimap m n = Bimap !m !n
instance Show m => Show (Bimap m n) where
showsPrec p (Bimap m _) = showParen (p > 10) $
showString "Bimap " . showsPrec 11 m
invert :: Bimap m n -> Bimap n m
invert (Bimap m n) = Bimap n m
instance (Mappy k v kv, Mappy v k vk) => Mappy k v (Bimap kv vk) where
empty = Bimap empty empty
insert k v (Bimap kv vk)
| Just k' <- lookup v vk
= Bimap (insert k v $ delete k' kv) (insert v k vk)
| otherwise
= Bimap (insert k v kv) (insert v k vk)
delete k m#(Bimap kv vk)
| Just v <- lookup k kv
= Bimap (delete k kv) (delete v vk)
| otherwise
= m
lookup k (Bimap kv _) = lookup k kv
We can also define some wrappers to make it easier to write our desired map types.
newtype MapMap k v = MapMap (Bimap (Map k v) (Map v k)) deriving (Show, Mappy k v)
newtype IMM v = IMM (Bimap (IntMap v) (Map v Int)) deriving (Show, Mappy Int v)
The following (unoptimal) code generates all the subsets of size N for certain subset.
This code works but, as I said, is highly unoptimal. Using an intermediate list to avoid the O(log(n)) of Set.insert doesn't seem help due to the large cost of later reconverting the list to a Set
Can anybody suggest how to optimize the code?
import qualified Data.Set as Set
subsetsOfSizeN :: Ord a => Int -> Set.Set a -> Set.Set (Set.Set a)
subsetsOfSizeN n s
| Set.size s < n || n < 0 = error "subsetOfSizeN: wrong parameters"
| otherwise = doSubsetsOfSizeN n s
where doSubsetsOfSizeN n s
| n == 0 = Set.singleton Set.empty
| Set.size s == n = Set.singleton s
| otherwise =
case Set.minView s of
Nothing -> Set.empty
Just (firstS, restS) ->
let partialN n = doSubsetsOfSizeN n restS in
Set.map (Set.insert firstS) (partialN (n-1)) `Set.union` partialN n
This is inspired by Pascal's triangle.
choose :: [b] -> Int -> [[b]]
_ `choose` 0 = [[]]
[] `choose` _ = []
(x:xs) `choose` k = (x:) `fmap` (xs `choose` (k-1)) ++ xs `choose` k
This code works but, as I said, is highly unoptimal.
Doesn't seem so terribly bad to me. The number of subsets of size k of a set of size n is n `choose` k which grows rather fast for k ~ n/2. So creating all the subsets must scale badly.
Using an intermediate list to avoid the O(log(n)) of Set.insert doesn't seem help due to the large cost of later reconverting the list to a Set.
Hmm, I found using lists to give better performance. Not asymptotically, I think, but a not negligible more-or-less constant factor.
But first, there is an inefficiency in your code that is simple to repair:
Set.map (Set.insert firstS) (partialN (n-1))
Note that Set.map must rebuild a tree from scratch. But we know that firstS is always smaller than any element in any of the sets in partialN (n-1), so we can use Set.mapMonotonic that can reuse the spine of the set.
And that principle is also what makes lists attractive, the subsets are generated in lexicographic order, so instead of Set.fromList we can use the more efficient Set.fromDistinctAscList. Transcribing the algorithm yields
onlyLists :: Ord a => Int -> Set.Set a -> Set.Set (Set.Set a)
onlyLists n s
| n == 0 = Set.singleton Set.empty
| Set.size s < n || n < 0 = error "onlyLists: out of range n"
| Set.size s == n = Set.singleton s
| otherwise = Set.fromDistinctAscList . map Set.fromDistinctAscList $
go n (Set.size s) (Set.toList s)
where
go 1 _ xs = map return xs
go k l (x:xs)
| k == l = [x:xs]
| otherwise = map (x:) (go (k-1) (l-1) xs) ++ go k (l-1) xs
which in the few benchmarks I've run is between 1.5 and 2× faster than the amended algorithm using Sets.
And that is in turn, in my criterion benchmarks, nearly twice as fast as dave4420's.
subsets :: Int -> [a] -> [[a]]
subsets 0 _ = [[]]
subsets _ [] = []
subsets k (x:xs) = map (x:) (subsets (k - 1) xs) ++ subsets k xs
First, use a better algorithm.
Look at your final line:
Set.map (Set.insert firstS) (partialN (n-1)) `Set.union` partialN n
Evaluating doSubsetsOfSizeN k (Set.fromList $ 1:2:xs) will involve evaluating doSubsetsOfSizeN (k-1) (Set.fromList xs) twice (once when inserting 1, and once when inserting 2). This duplication is wasteful.
Enter a better algorithm.
mine :: Ord a => Int -> Set.Set a -> Set.Set (Set.Set a)
mine n s | Set.size s < n || n < 0 = Set.empty
| otherwise = Set.foldr cons nil s !! n
where
nil :: Ord a => [Set.Set (Set.Set a)]
nil = Set.singleton Set.empty : repeat Set.empty
cons :: Ord a => a -> [Set.Set (Set.Set a)] -> [Set.Set (Set.Set a)]
cons x sets = zipWith Set.union sets
(Set.empty : map (Set.map $ Set.insert x) sets)
mine 9 (Data.Set.fromList [0..18]) `seq` () is faster than subsetsOfSizeN 9 (Data.Set.fromList [0..18]) `seq` () and should have better asymptotic performance.
I haven't tried optimising this any further. There may be a better algorithm still.
(If the cost of insert and fromList are issues, you should consider giving back a list of lists instead of a set of sets.)
I found this, may be it can help you
f [] = [[1]]
f l = (:) [u] l'
where
u = succ (head (head l))
l' = (++) l (map(\x->(:) u x) l)
fix f n = if (n==0) then [] else f (fix f (n-1))
To test it
$ length $ (fix f 10) => 1023 -- The empty set is always include then == 1024