Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

Sign up
Here's how it works:
  1. Anybody can ask a question
  2. Anybody can answer
  3. The best answers are voted up and rise to the top

This is probably a very straightforward thing I am missing, and probably also a duplicate(!), but I can't for the life of me think how to do this cleaner. I want to achieve what bb[n] does:

aa[list1_, list2_] := Select[Subsets[list1], 
Length@Complement[#, Complement[list1, list2]] == Length@list2 &]
bb[a_] := With[{c = x[#] & /@ Range@Length@a}, 
aa[c, #] & /@ Subsets[c] /. Thread[c -> a]]

eg

in: bb[{1,2,3}]

out:

{{}, {1}, {2}, {3}, {1, 2}, {1, 3}, {2, 3}, {1, 2, 3}}
{{1}, {1, 2}, {1, 3}, {1, 2, 3}}
{{2}, {1, 2}, {2, 3}, {1, 2, 3}}
{{3}, {1, 3}, {2, 3}, {1, 2, 3}}
{{1, 2}, {1, 2, 3}}
{{1, 3}, {1, 2, 3}}
{{2, 3}, {1, 2, 3}}
{{1, 2, 3}}

Please could someone suggest a simpler, cleaner, more succinct way of achieving the above?

share|improve this question
up vote 4 down vote accepted

Update for speed

It was slightly slower then bb in the OP so I tweaked it a bit. It used to use

Function[{x}, Select[SubsetQ[#, x] &]@s] /@ s

but the new Function in g below, although bigger, completes in $\frac{4}{5}$ the time than bb. Now, on my machine:

First@AbsoluteTiming[g[Range[11]];]
(* 17.6471 *)

First@AbsoluteTiming[bb[Range[11]];]
(* 22.4707 *)

enter image description here

Update for duplicates

Using Subsets on the position vector of the list and then extracting from the list position subset as the Part spec.

g[t_List] :=
 With[{s = Subsets[Range@Length@t]},
  Map[
   t[[#]] &,
   Function[{x}, 
    Insert[x, 1]@Select[SubsetQ[#, x] &]@Select[Length@# > Length@x &]@s] /@ s,
   {2}]
  ]


g[{1, 2, 3}]

(*
{
 {{}, {1}, {2}, {3}, {1, 2}, {1, 3}, {2, 3}, {1, 2, 3}},
 {{1}, {1, 2}, {1, 3}, {1, 2, 3}},
 {{2}, {1, 2}, {2, 3}, {1, 2, 3}},
 {{3}, {1, 3}, {2, 3}, {1, 2, 3}},
 {{1, 2}, {1, 2, 3}},
 {{1, 3}, {1, 2, 3}},
 {{2, 3}, {1, 2, 3}},
 {{1, 2, 3}}
}
*)

Works with duplicates.

g[{1, 1, 2}]

(*
{
 {{}, {1}, {1}, {2}, {1, 1}, {1, 2}, {1, 2}, {1, 1, 2}}, 
 {{1}, {1, 1}, {1, 2}, {1, 1, 2}}, 
 {{1}, {1, 1}, {1, 2}, {1, 1, 2}}, 
 {{2}, {1, 2}, {1, 2}, {1, 1, 2}}, 
 {{1, 1}, {1, 1, 2}}, 
 {{1, 2}, {1, 1, 2}}, 
 {{1, 2}, {1, 1, 2}}, 
 {{1, 1, 2}}
}
*)

Hope this helps

share|improve this answer
    
another nice approach, thanks - will still need that fix for duplicates though - see SimonWoods' 1st and second edit (try g@{1,1,2}) – martin Jan 22 at 22:18
1  
@martin Updated for duplicates. It basically Maps Part into the result of the Function in the original post with Subsets of the position vector of the list instead of the list itself. – Edmund Jan 23 at 0:14
    
@martin Updated for speed. – Edmund Jan 23 at 13:03
    
nice improvements :) – martin Jan 23 at 18:34

How about

f = With[{s = Subsets[#], r = Subsets[Range@Length@#]},
 Pick[s, #] & /@ Outer[SubsetQ[#2, #1] &, r, r, 1]] &

f[{1, 1, 2}] // Column

(* 
{{},{1},{1},{2},{1,1},{1,2},{1,2},{1,1,2}}
{{1},{1,1},{1,2},{1,1,2}}
{{1},{1,1},{1,2},{1,1,2}}
{{2},{1,2},{1,2},{1,1,2}}
{{1,1},{1,1,2}}
{{1,2},{1,1,2}}
{{1,2},{1,1,2}}
{{1,1,2}}
*)
share|improve this answer
    
that's nice, but doesn't give same output as bb if duplicates - eg bb@{1,1,2} – martin Jan 22 at 21:41
    
Looks like we had similar ideas for a fix :-) – Simon Woods Jan 22 at 21:48
    
looks good now - much cleaner - thanks! :) – martin Jan 22 at 21:49
1  
FYI in your original code Flatten[{#[[1]] -> #[[2]]} & /@ Transpose@{c, a}] can be written more succinctly as Thread[a -> c] – Simon Woods Jan 22 at 21:51
    
thanls - that is useful to know - will leave Q open for a bit as per MMA SE etiquette, but will no doubt accept shortly :) – martin Jan 22 at 21:53

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.