# Subset-type function construction

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?

-

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 *)


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

-
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
@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

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}}
*)

-
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
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