Tag Info

Solution minimal[sets_] := Module[{f}, f[x__] := (f[x, ___] = Sequence[]; {x}); SetAttributes[f, Orderless]; f @@@ Sort @ sets ] If the original order in the subsets must be retained one may introduce an auxiliary symbol without loss of performance: minimal2[sets_] := Module[{f, g}, f[x__] := (f[x, ___] = True; False); g[a_] /; ...

Hybrid Mathematica - Java solution Since the top-level solution from EDIT is still rather slow, here is a Java port of it. To use it, you have to first load the Java reloader into your session. Code Having done that, we have to compile this class: JCompileLoad@"import java.util.*; public class MinSubsets{ public static Object[] ...

You could do something like minSubsets[lst_] := DeleteDuplicates[SortBy[lst, Length], Intersection[#1, #2] === Sort[#1] &] Then for the example in the question you get lst = {{a, b}, {b, c}, {a, b, c}, {a, b, e}, {a, c, e}, {a, e, d, f}}; minSubsets[lst] (* out: {{a, b}, {b, c}, {a, c, e}, {a, e, d, f}} *)

Subsets takes an optional 3rd argument as Subsets[list, {n}, k] that gives you the kth sublist of length n. Since your sublists are in sequence, you'll always need k = 1. You can then use this as: MapIndexed[First@Subsets[list, #2, 1] &, list] (* {{a}, {a, b}, {a, b, c}, {a, b, c, d}} *) Another alternative would be: Reverse@Most@NestWhileList[Most, ...

A variant using Take. list~Take~# & /@ Range@Length@list {{a}, {a, b}, {a, b, c}, {a, b, c, d}} One using NestList: NestList[Most, list, Length@list - 1] {{a, b, c, d}, {a, b, c}, {a, b}, {a}}

I'll show a method based on an algorithm by Bentley, Clarkson, and Levine. --- edit --- Their idea is to presort so that any obviously minimal elements are at the front. In this case, minimal length suffices for the test of being "obviously minimal". Then loop over remaining elements. For each one: Loop from beginning until we hit elements of same ...

There are two built-in functions to generate pairs, either with (Tuples) or without (Subsets) duplication. Since your question states the number of iterations as $n*(n-1)/2$ I believe you want the latter: set = {1, 2, 3, 4}; Subsets[set, {2}] {{1, 2}, {1, 3}, {1, 4}, {2, 3}, {2, 4}, {3, 4}} The short notation for Apply at level 1 is @@@, so this ...

I would use: data = {1, 20, 3, 40}; Join @@ Permutations /@ IntegerPartitions[Length@data]; results = Internal`PartitionRagged[data, #] & /@ % {{4}, {3, 1}, {1, 3}, {2, 2}, {2, 1, 1}, {1, 2, 1}, {1, 1, 2}, {1, 1, 1, 1}} {{{1, 20, 3, 40}}, {{1, 20, 3}, {40}}, {{1}, {20, 3, 40}}, {{1, 20}, {3, 40}}, {{1, 20}, {3}, {40}}, {{1}, {20, 3}, {40}}, ...

vertices = Range[10]; pairs = Tuples[vertices, 2]; func[x__] := First@x <= Last@x; edges = Pick[pairs, func[#] & /@ pairs]; (* or *) edges = Pick[pairs, Boole[func[#]] & /@ pairs, 1]; Graph[DirectedEdge @@@ edges, VertexLabels -> "Name", ImagePadding -> 20] Graph[DirectedEdge @@@ edges, VertexLabels -> "Name", ImagePadding -> 20] ...

A main idea of a pattern-based solution I don't know why we should make life so complicated, since you can always use things like Intersection and Complement to test whether a given set is a subset of another set. But if you want to use the pattern-matcher, here is one option: ClearAll[set]; SetAttributes[set, {Orderless, Flat, OneIdentity}]; ...

This is just to give set the proper attributes and make it simplify double ___ and __ ClearAll[set]; set[a___, Verbatim[___], Verbatim[___] .., b___] := set[a, ___, b]; set[a___, Verbatim[__], Verbatim[__] .., Verbatim[___] ..., b___] := set[a, __, b]; SetAttributes[set, {Orderless, Flat, OneIdentity}]; The patterns will be a boolean function of ...

I guess you're trying to plot the set of points $(x,y,z)$ such that $3x^2>2y^2+z^2$ and $x^2+y^2=1$. Now RegionPlot3D only works for inequalities, while ContourPlot3D only works for equations. But you can use ContourPlot3D on the equation and supply it the inequality as a RegionFunction. ContourPlot3D[x^2 + y^2 == 1, {x, -1, 1}, {y, -1, 1}, {z, -2, 2}, ...

Edit: Corrected the transcription of the solution, in final line. This is one way to find Exact Cover solutions. It exploits the simple fact that non-disjoint (overlapping) subsets cannot be together in an exact cover solution, which must constitute a partition of the set x. My approach is almost certainly not the most efficient way, but it was how I was ...

Yes, there are definitely shorter, non-loop ways to do this. Define your link-defining function like this (with whatever test you need as the first argument to If: islinked[a_Integer?Positive, b_Integer?Positive] := If[Mod[a, 3] == 0 && Mod[b, 2] == 1, a -> b, {}] You can then Apply this at the level of each row using the @@@ shorthand. I ...

You might generate all subsets by placing special markers (asterisks) where a list should be split. data = {1, 20, 3, 40}; (* The asterisks "*" indicate where a list should be split *) data1 = Insert[data, "*", #] & /@ (Subsets[Range[2, Length[data]]] /. a_Integer :> {a}) (* out *) {{1, 20, 3, 40}, {1, "*", 20, 3, 40}, {1, 20, "*", 3, 40}, {1, ...

check[l_] := If[ ++$pos; Length@$minimals === Total @ Unitize[BitNot[l] ~BitAnd~ $minimals], $minimalIndicator += 2^$pos; AppendTo[$minimals, l] ] binary[data2_, alphabet_] := Total[2^(Length@alphabet - #), {2}] &[ data2 /. Dispatch@MapIndexed[# -> #2[[1]] &, alphabet] ] minimalR[data_] := Block[{$minimals = {}, $pos = -1, ...

As always, there are many possible ways of doing things. Here's an example using Fold: Fold[If[With[{u = #1~Join~{Union @@ #1}}, MemberQ[u, Alternatives @@ Function[{x}, Intersection[x, #2]] /@ u]], #1, {Sequence @@ #1, #2}] &, {First@#}, Rest@#] &@Map[Sort, list, {0, 1}]; (* {{a, b}, {b, c}, {a, c, e}, {a, e, d, f}} *)

I remember helping someone else with a similar problem recently in chat. Anyway, here's a solution using //. or ReplaceRepeated. If your lists are very large, then you should look into alternative solutions, because the performance of //. along with ___ will degrade quickly. Otherwise, it's a fine solution and I'd use it if I had a similar problem. list = ...

I will use David Carraher's example to illustrate a way using integer linear programming. x = Range[7]; a[1] = {1, 4, 7}; a[2] = {1, 4}; a[3] = {4, 5, 7}; a[4] = {3, 5, 6}; a[5] = {2, 3, 6, 7}; a[6] = {2, 7}; First we turn these subsets into 0-1 sets (think of them as bitvectors) representing whether a given element is in or not. For purposes of later ...

pairs = {{1, 2}, {3, 4}, {7, 4}, {2, 5}, {5, 8}}; relativesF=ConnectedComponents[Graph[UndirectedEdge @@ # & /@ #]]& relativesF@pairs (* {{1, 2, 5, 8}, {3, 4, 7}} *) or relativesF2 = DeleteDuplicates/@ Flatten/@ Gather[#, (Intersection[#1, #2] !={} &)] &; FixedPoint[relativesF2 , pairs] (* {{1, 2, 5, 8}, {3, 4, 7}} *) or ...

Needs["Combinatorica`"] Map[data[[#]] &, Select[SetPartitions[Range[4]], OrderedQ[Flatten@#] &], {2}] giving (*{ {{1, 20, 3, 40}}, {{1}, {20, 3, 40}}, {{1, 20}, {3, 40}}, {{1, 20, 3}, {40}}, {{1}, {20}, {3, 40}}, {{1}, {20, 3}, {40}}, {{1, 20},{3}, {40}}, {{1}, {20}, {3}, {40}} }*)

Perhaps ContourPlot3D is useful, with an expression for x, y, and z, plus added constraints? ContourPlot3D[Sin[x] Cos[y] Tan[z], {x, -Pi, Pi}, {y, -Pi, Pi}, {z, -Pi, Pi}, RegionFunction -> Function[{x, y, z}, (x^2 > (2 y^2 + z^2 ))], AxesStyle -> White Background -> Black]

This solution is in the same spirit as your approach: Clear@findSets findSets[list_, all_, any_, none_] := Block[{set}, SetAttributes[set, {Flat, Orderless}]; Select[set @@@ list, Function[s, !FreeQ[s, set @@ all] && Or @@ (! FreeQ[s, set@#] & /@ any /. {} -> True) && And @@ ...