4
$\begingroup$

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?

$\endgroup$
4
$\begingroup$

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

$\endgroup$
  • $\begingroup$ another nice approach, thanks - will still need that fix for duplicates though - see SimonWoods' 1st and second edit (try g@{1,1,2}) $\endgroup$ – martin Jan 22 '16 at 22:18
  • 1
    $\begingroup$ @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. $\endgroup$ – Edmund Jan 23 '16 at 0:14
  • $\begingroup$ @martin Updated for speed. $\endgroup$ – Edmund Jan 23 '16 at 13:03
  • $\begingroup$ nice improvements :) $\endgroup$ – martin Jan 23 '16 at 18:34
4
$\begingroup$

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

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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