# Tag Info

35

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_] /; ...

21

lst={a,b,c,d}; ReplaceList[lst,{x__, ___} :> {x}] Speaking of "common operation": Table[lst[[;; i]], {i, Length@lst}]

18

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

16

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[] ...

14

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

14

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

14

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

14

You can use ReplaceList with a helper function which has the Orderless attribute: ClearAll[f]; SetAttributes[f, Orderless]; ReplaceList[f[a, b, c], f[a___, b___, c___] :> {{a}, {b}, {c}}] // DeleteCases[#, {}, -1] & // Union // Column The DeleteCases and Union are required because the output from ReplaceList includes the empty list {} as a ...

13

Take all subsets of length 10, then for each one find all splits into two sets of five such that the first of the ten is in the first part of the split. In[29]:= Timing[ msets = Subsets[Range[12], {10}]; m2 = Flatten[ Map[With[{fst = First[#], subs = Subsets[Rest[#], {4}], mset = #}, With[{s2 = Map[Join[{fst}, #] &, subs]}, Map[{#, ...

13

Perhaps the following SetAttributes[set, Orderless]; set[elms___] := With[{nodups = DeleteDuplicates@{elms}}, set @@ nodups /; {elms} =!= nodups] So set[a, b, c, d] would represent a set with elements a, b, c, and d. To compare, just use == or ===. It automatically sorts and removes duplicates s1 = set[a, b, c, d]; s2 = set["o", b, a, aa, dd]; s1 =...

13

There is an undocumented function LongestAscendingSequence LongestAscendingSequence[list] {1, 3, 4, 6} This was mentioned here and here in comments. I hope it will not be treated as a duplicate. I think Q&A-style on SE is more appropriate for this question. For completeness I ask the second question. It seem to be much simpler but I can't find any ...

13

s = {w, x, y, z}; sum = {-1, 3, 5, 8}; add = Plus @@@ Subsets[s, {3}] (* {w + x + y, w + x + z, w + y + z, x + y + z} *) Solve[add == sum, s] (* {{w -> -3, x -> 0, y -> 2, z -> 6}} *)

12

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

11

mat = ConstantArray[1, {4, 4}] - IdentityMatrix[4]; LinearSolve[mat, {-1, 3, 5, 8}] {6, 2, 0, -3}

10

Ad. I These should be the most efficient and tersest Ceiling[ Range @ 27 / 3 ] or Array[ Ceiling[#/3] &, 27] yield {1, 1, 1, 2, 2, 2, 3, 3, 3, 4, 4, 4, 5, 5, 5, 6, 6, 6, 7, 7, 7, 8, 8, 8, 9, 9, 9} they both can be tersely written in the Front End (see details of Ceiling) as: or Ad.II For the second problem there are many approaches, ...

10

Try the following. Note I assumed from OP that elements are non-zero integers. This could of course be adapted to other cases with appropriate mapping. getmasks[listarg_] := Reverse[Transpose[ IntegerDigits[Fold[BitSet[#1, #2] &, 0, #] & /@ listarg, 2, Max[listarg] + 1]]][[Min[listarg] + 1 ;; Max[listarg] + 1]]; getneighbors[listarg_,...

10

I don't pretend this is the most efficient or pretty, but here's a go at what I think you're after (see latter part of post for faster and simpler realizations): a = {1, 1, 2, 1, 1, 3}; b = {1, 5, 5, 1}; result = Join[ Flatten[ConstantArray @@@ Flatten[Replace[Cases[GatherBy[Join[Tally[#1], Tally[#2]], First], {{Alternatives @@ a, ...

10

This question may be a duplicate but for the time being: list = Range[300]; The number of subsets length 25: n = Binomial[300, 25] 1953265141442868389822364184842211512 Five samples: samp = RandomInteger[{1, n}, 5] {1097179597483122074395819626389736050, 1278400886908268917844987164926797363, 1855898035549513136165016617586671669, ...

9

In a strict meaning the answer is no. A mathematical concept of a set is so basic and general, that one even cannot imagine most of sets and the more it concerns the possibility of their computer representations. For some hints of surprising properties of infinite sets see e.g. Continuum Hypothesis or GĂ¶del's theorem. If you relate your question to finite ...

9

I am not sure this wins any speed contests, but it is a purely functional solution: FoldList[#1~Join~{#2} &, {First@#}, Rest@#]& @ {a, b, c, d, e} (* {{a}, {a, b}, {a, b, c}, {a, b, c, d}, {a, b, c, d, e}} *)

9

If I'm not mistaken you can do this: (I will replace [EmptySet] with ES because I have troubles formatting it here) a = { ES, {ES}, {{ES}, ES}}; b = {#, {#, #2}} & @@@ Tuples[a, {2}]; % // Column {ES, {ES, ES}} {ES, {ES, {ES}}} {ES, {ES, {{ES}, ES}}} {{ES}, {{ES}, ES}} {{ES}, {{ES}, {ES}}} {{ES}, {{ES}, {{ES}, ES}}} {{{ES}, ES}, {{{ES}, ES}, ES}} {{{...

9

Okay, I'll go first. This is not an answer per se to the post, but more an invitation to write a fast sorting code for machine reals. That way we can get some sense of what might be feasible (showing timings of existing implementations would also be useful; I leave that for others). In Mathematica. Using Compile, of course. The point is to illustrate a few ...

9

More a comment than an answer, (but I have not enough reputation): This is a well known problem, although by far not solved. (One might not expect, but is of very practical relevance in software testing.) You find a lot of interesting stuff (theory and algorithms) by googling "orthogonal array" or - even better - "mixed orthogonal array". Also the book "...

8

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}}, {...

8

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}]; ClearAll[...

8

I think RandomSample already does exactly what you need: RandomSample: RandomSample[Range[300], 25] (* {292, 257, 36, 83, 259, 245, 280, 270, 24, 236, 186, 100, 300, 240, 176, 295, 42, 105, 97, 106, 60, 114, 63, 25, 253} *) Table[RandomSample[Range[300], 25], {5}] {{221, 54, 124, 64, 168, 91, 149, 25, 142, 87, 184, 288, 93, 105, 95, 195, 264, 180, ...

7

This should be fast enough: Flatten[ Map[ Transpose[{ConstantArray[#1,{Length[#2]}],#2}]&@@ {#,Subsets[Complement[Range[12],#],{5}]}&, Subsets[Range[12],{5}] ], 1]//Short//Timing (* ==> {0.031,{{{1,2,3,4,5},{6,7,8,9,10}},<<16630>>,{{8,9,10,11,12},{3,4,5,6,7}}}} *) If you don't want double-...

7

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, \$...

7

What about Accumulate: Function[lst, {{lst[[1]]}}~Join~Rest[Accumulate[lst] /. Plus -> List]]@{a, b, c, d, e} Unfortunately it doesn't accept a custom function other than Plus and will not work for numerical list...

7

A brute force solution is to check all possible values of this function. num = {1/10, 1/2, 4/7, 3/5, 2/3}; pow = {0, 1, 2, 3, 4}; To obtain value for one combination use the Inner function Inner[Power, num, pow, Plus] (* => 2222701/992250 *) Then we apply function Inner[Power, num, #, Plus]& on all permutations prm = Permutations[pow]; val = ...

Only top voted, non community-wiki answers of a minimum length are eligible