# Tag Info

29

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

20

Metropolis algorithm Update: ~15x speedup with Compile! I propose an original solution, which consists in using the Metropolis algorithm. It is a very general approach, which is applicable for any probability density function in any dimensions. Metropolis /: RandomDistributionVector[ Metropolis[pdf_, u0_, s_: 1, n0_: 100, chains_: 200], n_Integer, ...

16

Lets call your plot res. res = RegionPlot[And @@ Table[ Dot[{Phi1, Phi2}, Eta[b]] <= Norm[NI[Pi] - Eta[b]]^2 + 2, {b, 0, 2 Pi, 2 Pi/10}], {Phi1, -7, 7}, {Phi2, -7, 7}]; Lets extract the mesh Mathematica is generating by default. Use more PlotPoints to get more triangular mesh of your 2D region. pts = res[[1, 1]]; (* Vertices *) {triangles, qd} = ...

15

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

15

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

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

13

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

12

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

12

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

11

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

10

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

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

9

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

9

Being this the first answer at the site using the Region context, I think it deserves an entry on its own: AppendTo[$ContextPath, "Region"] z = 0; RegionPlot[ RegionProperty[ TransformedRegion[ ParametricRegion[{{p1, p2, p4}, 0 < p1 < 1 && ... 9 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]]; ... 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 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}} ... 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 = ... 7 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}]; ... 7 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 ... 7 I enjoy the solution of PlatoManiac and I want to improve it Eta[a_] := {Cos[a], Sin[a]} NI[a_] := {Cos[a], Sin[a]} res = RegionPlot[ And @@ Table[ Dot[{Phi1, Phi2}, Eta[b]] <= Norm[NI[Pi] - Eta[b]]^2 + 2, {b, 0, 2 Pi, 2 Pi/10}], {Phi1, -7, 7}, {Phi2, -7, 7}]; points = res[[1, 1]]; {id3, id4} = Cases[res[[1]], Polygon[{a___}] -> {a}, ... 6 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] ... 5 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 ... 5 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, ... 5 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 ... 5 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, ... 5 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 ... 5 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}, ... 5 A variation: mySet = {1/10, 1/2, 4/7, 3/5, 2/3}; perms = Permutations[mySet]; powersums = Total[Transpose @ perms^Range[0, 4]]; Extract[perms, Position[powersums, Max[powersums]]] {{1/10, 4/7, 2/3, 3/5, 1/2}} Another variation (beware: slower on large sets): Last @ Sort @ With[{perms = Permutations[{1/10, 1/2, 4/7, 3/5, 2/3}]}, ... 5 Since you want to count the elements of each of the classes, use Tally. With Last[#]!&, you define a function that gets the factorials in the denominator: numberOfCases[s_] := Length[s]!/Times @@ (Last[#]! & /@ Tally[s]) numberOfCases[{a, a, b, a, c, b, a}] 105 That code instantiates the formula$N!/(n_1!n_2!…n_k!)$where$N\$ is the number of ...

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